Compare commits
No commits in common. "typeless" and "gh-pages" have entirely different histories.
|
@ -1,3 +0,0 @@
|
||||||
compiled/
|
|
||||||
doc/
|
|
||||||
scratch/
|
|
File diff suppressed because one or more lines are too long
File diff suppressed because one or more lines are too long
File diff suppressed because one or more lines are too long
13
Makefile
13
Makefile
|
@ -1,13 +0,0 @@
|
||||||
all: setup
|
|
||||||
|
|
||||||
clean:
|
|
||||||
find . -name compiled -type d | xargs rm -rf
|
|
||||||
|
|
||||||
setup:
|
|
||||||
raco setup $$(basename $$(pwd))
|
|
||||||
|
|
||||||
link:
|
|
||||||
raco pkg install --link $$(pwd)
|
|
||||||
|
|
||||||
unlink:
|
|
||||||
raco pkg remove $$(basename $$(pwd))
|
|
File diff suppressed because one or more lines are too long
79
README.md
79
README.md
|
@ -1,79 +0,0 @@
|
||||||
# Marketplace: Bringing the Network into the Programming Language
|
|
||||||
|
|
||||||
Marketplace is a concurrent language able to express communication,
|
|
||||||
enforce isolation, and manage resources. Network-inspired extensions
|
|
||||||
to a functional core represent imperative actions as values, giving
|
|
||||||
side-effects locality and enabling composition of communicating
|
|
||||||
processes.
|
|
||||||
|
|
||||||
Collaborating programs are grouped within task-specific *virtual
|
|
||||||
machines* (VMs) to scope their interactions. Conversations between
|
|
||||||
programs are multi-party (using a publish/subscribe medium), and
|
|
||||||
programs can easily participate in many such conversations at once.
|
|
||||||
|
|
||||||
Marketplace makes *presence* notifications an integral part of
|
|
||||||
pub/sub. Programs react to presence and absence notifications that
|
|
||||||
report the comings and goings of their peers. Presence serves to
|
|
||||||
communicate changes in demand for and supply of services, both within
|
|
||||||
a VM and across *nested VM layers*. Programs can give up
|
|
||||||
responsibility for maintaining presence information and for scoping
|
|
||||||
group communications to their containing VM.
|
|
||||||
|
|
||||||
## Documentation
|
|
||||||
|
|
||||||
A (draft) manual for Marketplace is available
|
|
||||||
[here](http://tonyg.github.io/marketplace/).
|
|
||||||
|
|
||||||
## The code
|
|
||||||
|
|
||||||
This repository contains a [Racket](http://racket-lang.org/) package,
|
|
||||||
`marketplace`, which includes
|
|
||||||
|
|
||||||
- the implementation of the `#lang marketplace` language, in the
|
|
||||||
[top directory](https://github.com/tonyg/marketplace/tree/typeless/).
|
|
||||||
|
|
||||||
- a TCP echo server example, in
|
|
||||||
[`examples/echo-paper.rkt`](https://github.com/tonyg/marketplace/tree/typeless/examples/echo-paper.rkt).
|
|
||||||
|
|
||||||
- a TCP chat server example, in
|
|
||||||
[`examples/chat-paper.rkt`](https://github.com/tonyg/marketplace/tree/typeless/examples/chat-paper.rkt).
|
|
||||||
|
|
||||||
- Haskell, Erlang and Python implementations of the chat server for comparison, in
|
|
||||||
[`examples/chat.hs`](https://github.com/tonyg/marketplace/tree/typeless/examples/chat.hs),
|
|
||||||
[`chat.erl`](https://github.com/tonyg/marketplace/tree/typeless/examples/chat.erl),
|
|
||||||
and
|
|
||||||
[`chat.py`](https://github.com/tonyg/marketplace/tree/typeless/examples/chat.py)
|
|
||||||
respectively.
|
|
||||||
|
|
||||||
## Compiling and running the code
|
|
||||||
|
|
||||||
You will need Racket version 6.1.x or later.
|
|
||||||
|
|
||||||
Once you have Racket installed, run
|
|
||||||
|
|
||||||
raco pkg install marketplace
|
|
||||||
|
|
||||||
to install the package from the Racket package repository, or
|
|
||||||
|
|
||||||
raco pkg install --link `pwd`
|
|
||||||
|
|
||||||
from the root directory of the Git checkout to install the package
|
|
||||||
from a local snapshot. (Alternatively, `make link` does the same thing.)
|
|
||||||
This will make `#lang marketplace` available to programs.
|
|
||||||
|
|
||||||
At this point, you may load and run any of the example `*.rkt` files
|
|
||||||
in the
|
|
||||||
[`examples/`](https://github.com/tonyg/marketplace/tree/typeless/examples/)
|
|
||||||
directory.
|
|
||||||
|
|
||||||
Note that both the echo server and chat server examples do not print
|
|
||||||
any output on standard output: instead, they simply start running and
|
|
||||||
silently await TCP connections. Once one of the servers is running, in
|
|
||||||
a separate window, try `telnet localhost 5999`.
|
|
||||||
|
|
||||||
Note also that both the echo server and the chat server use port 5999,
|
|
||||||
so you cannot run both simultaneously.
|
|
||||||
|
|
||||||
## Copyright
|
|
||||||
|
|
||||||
Copyright © Tony Garnock-Jones 2010, 2011, 2012, 2013, 2014.
|
|
|
@ -1,40 +0,0 @@
|
||||||
#lang racket/base
|
|
||||||
|
|
||||||
(require racket/match)
|
|
||||||
(require "structs.rkt")
|
|
||||||
(require "roles.rkt")
|
|
||||||
(require "vm.rkt")
|
|
||||||
(require "process.rkt")
|
|
||||||
|
|
||||||
(provide do-add-endpoint)
|
|
||||||
|
|
||||||
;; do-add-endpoint : (All (State) PreEID Role (Handler State) (process State) vm
|
|
||||||
;; -> (values (Option (process State)) vm))
|
|
||||||
(define (do-add-endpoint pre-eid role h p state)
|
|
||||||
(define new-eid (eid (process-pid p) pre-eid))
|
|
||||||
(define old-endpoint (hash-ref (process-endpoints p) pre-eid (lambda () #f)))
|
|
||||||
(define new-endpoint (endpoint new-eid role h))
|
|
||||||
(if old-endpoint
|
|
||||||
;; We are *updating* an existing endpoint's behaviour.
|
|
||||||
(if (roles-equal? (endpoint-role old-endpoint)
|
|
||||||
(endpoint-role new-endpoint))
|
|
||||||
(values (install-endpoint p new-endpoint)
|
|
||||||
state)
|
|
||||||
;; TODO: Make this error fatal for the process, not the VM!
|
|
||||||
(error 'do-add-endpoint
|
|
||||||
"Roles must be equal when updating an endpoint: ~v vs ~v"
|
|
||||||
old-endpoint
|
|
||||||
new-endpoint))
|
|
||||||
;; We are installing a *new* endpoint.
|
|
||||||
;; TODO: Decide whether to signal a process' endpoints about
|
|
||||||
;; *its own* matching endpoints.
|
|
||||||
(let-values (((p state) (notify-route-change-vm (install-endpoint p new-endpoint)
|
|
||||||
new-endpoint
|
|
||||||
presence-event
|
|
||||||
state)))
|
|
||||||
(values p state))))
|
|
||||||
|
|
||||||
;; install-endpoint : (All (State) (process State) (endpoint State) -> (process State))
|
|
||||||
(define (install-endpoint p ep)
|
|
||||||
(define pre-eid (eid-pre-eid (endpoint-id ep)))
|
|
||||||
(struct-copy process p [endpoints (hash-set (process-endpoints p) pre-eid ep)]))
|
|
|
@ -1,44 +0,0 @@
|
||||||
#lang racket/base
|
|
||||||
|
|
||||||
(require racket/match)
|
|
||||||
(require "structs.rkt")
|
|
||||||
(require "roles.rkt")
|
|
||||||
(require "vm.rkt")
|
|
||||||
(require "process.rkt")
|
|
||||||
(require "quasiqueue.rkt")
|
|
||||||
|
|
||||||
(provide do-delete-endpoint
|
|
||||||
delete-all-endpoints)
|
|
||||||
|
|
||||||
;; do-delete-endpoint : (All (State) PreEID Reason (process State) vm
|
|
||||||
;; -> (values (process State) vm))
|
|
||||||
(define (do-delete-endpoint pre-eid reason p state)
|
|
||||||
(cond
|
|
||||||
[(hash-has-key? (process-endpoints p) pre-eid)
|
|
||||||
(define old-endpoint (hash-ref (process-endpoints p) pre-eid))
|
|
||||||
(let-values (((p state) (notify-route-change-vm (remove-endpoint p old-endpoint)
|
|
||||||
old-endpoint
|
|
||||||
(lambda (t) (absence-event t reason))
|
|
||||||
state)))
|
|
||||||
(values p state))]
|
|
||||||
[else
|
|
||||||
(values p state)]))
|
|
||||||
|
|
||||||
;; remove-endpoint : (All (State) (process State) (endpoint State) -> (process State))
|
|
||||||
(define (remove-endpoint p ep)
|
|
||||||
(define pre-eid (eid-pre-eid (endpoint-id ep)))
|
|
||||||
(struct-copy process p [endpoints (hash-remove (process-endpoints p) pre-eid)]))
|
|
||||||
|
|
||||||
;; delete-all-endpoints : (All (State) Reason (process State) vm
|
|
||||||
;; -> (values (process State) vm (QuasiQueue (Action vm))))
|
|
||||||
(define (delete-all-endpoints reason p state)
|
|
||||||
(let-values (((p state)
|
|
||||||
(for/fold ([p p] [state state])
|
|
||||||
([pre-eid (in-hash-keys (process-endpoints p))])
|
|
||||||
(do-delete-endpoint pre-eid reason p state))))
|
|
||||||
(values p
|
|
||||||
state
|
|
||||||
(list->quasiqueue
|
|
||||||
(map (lambda (pre-eid)
|
|
||||||
(delete-endpoint (eid (process-pid p) pre-eid) reason))
|
|
||||||
(hash-keys (process-meta-endpoints p)))))))
|
|
|
@ -1,42 +0,0 @@
|
||||||
#lang racket/base
|
|
||||||
|
|
||||||
(require racket/match)
|
|
||||||
(require "structs.rkt")
|
|
||||||
(require "roles.rkt")
|
|
||||||
(require "vm.rkt")
|
|
||||||
(require "log.rkt")
|
|
||||||
(require "process.rkt")
|
|
||||||
(require "action-delete-endpoint.rkt")
|
|
||||||
(require "quasiqueue.rkt")
|
|
||||||
|
|
||||||
(provide do-quit)
|
|
||||||
|
|
||||||
;; do-quit : (All (State) PID Reason (process State) vm
|
|
||||||
;; -> (values (Option (process State)) vm (QuasiQueue (Action vm))))
|
|
||||||
(define (do-quit killed-pid reason p state)
|
|
||||||
|
|
||||||
;; log-quit : (All (KilledState) (process KilledState) -> Void)
|
|
||||||
(define (log-quit p)
|
|
||||||
(marketplace-log (if reason 'warning 'info)
|
|
||||||
"PID ~v (~a) quits with reason: ~a"
|
|
||||||
killed-pid
|
|
||||||
(process-debug-name p)
|
|
||||||
(if (exn? reason)
|
|
||||||
(parameterize ([current-error-port (open-output-string)])
|
|
||||||
((error-display-handler) (exn-message reason) reason)
|
|
||||||
(get-output-string (current-error-port)))
|
|
||||||
(format "~v" reason))))
|
|
||||||
|
|
||||||
(if (equal? killed-pid (process-pid p))
|
|
||||||
(let-values (((p state meta-actions) (delete-all-endpoints reason p state)))
|
|
||||||
(log-quit p)
|
|
||||||
(values #f state meta-actions))
|
|
||||||
(let-values (((state maybe-killed-wp) (extract-process state killed-pid)))
|
|
||||||
(if (not maybe-killed-wp)
|
|
||||||
(values p state (empty-quasiqueue))
|
|
||||||
(apply values
|
|
||||||
(let ((killed-p maybe-killed-wp))
|
|
||||||
(log-quit killed-p)
|
|
||||||
(let-values (((killed-p state meta-actions)
|
|
||||||
(delete-all-endpoints reason killed-p state)))
|
|
||||||
(list p state meta-actions))))))))
|
|
|
@ -1,30 +0,0 @@
|
||||||
#lang racket/base
|
|
||||||
|
|
||||||
(require racket/match)
|
|
||||||
(require "structs.rkt")
|
|
||||||
(require "roles.rkt")
|
|
||||||
(require "vm.rkt")
|
|
||||||
(require "process.rkt")
|
|
||||||
|
|
||||||
(provide do-send-message)
|
|
||||||
|
|
||||||
;; do-send-message : (All (State) Orientation Message (process State) vm ->
|
|
||||||
;; (Values (Option (process State)) vm))
|
|
||||||
(define (do-send-message orientation body sender-p state)
|
|
||||||
(define message-role (role orientation body 'participant))
|
|
||||||
|
|
||||||
;; send-to-process : (All (State) (process State) -> (process State))
|
|
||||||
(define (send-to-process p)
|
|
||||||
(define endpoints (process-endpoints p))
|
|
||||||
(for/fold ([p p]) ([eid (in-hash-keys endpoints)])
|
|
||||||
(define e (hash-ref endpoints eid))
|
|
||||||
(cond
|
|
||||||
[(role-intersection message-role (endpoint-role e))
|
|
||||||
(run-ready p (send-to-user p (e) (quit-interruptk e)
|
|
||||||
((endpoint-handler e) (message-event message-role body))))]
|
|
||||||
[else
|
|
||||||
p])))
|
|
||||||
|
|
||||||
;; for each process in state (and also for p),
|
|
||||||
(values (send-to-process sender-p)
|
|
||||||
(process-map send-to-process state)))
|
|
|
@ -1,47 +0,0 @@
|
||||||
#lang racket/base
|
|
||||||
|
|
||||||
(require racket/match)
|
|
||||||
(require "structs.rkt")
|
|
||||||
(require "roles.rkt")
|
|
||||||
(require "vm.rkt")
|
|
||||||
(require "log.rkt")
|
|
||||||
(require "process.rkt")
|
|
||||||
|
|
||||||
(provide do-spawn)
|
|
||||||
|
|
||||||
;; do-spawn : (All (OldState)
|
|
||||||
;; process-spec
|
|
||||||
;; (Option (PID -> (InterruptK OldState)))
|
|
||||||
;; (process OldState)
|
|
||||||
;; Any
|
|
||||||
;; vm
|
|
||||||
;; -> (Values (Option (process OldState)) vm))
|
|
||||||
(define (do-spawn spec parent-k p debug-name state)
|
|
||||||
(define new-pid (vm-next-process-id state))
|
|
||||||
(marketplace-log 'info "PID ~v (~a) starting" new-pid debug-name)
|
|
||||||
;; new-cotransition : CoTransition
|
|
||||||
(define new-cotransition
|
|
||||||
(send-to-user* debug-name new-pid (e) (co-quit e)
|
|
||||||
((process-spec-boot spec) new-pid)))
|
|
||||||
;; co-quit : Reason -> CoTransition
|
|
||||||
(define ((co-quit e) k)
|
|
||||||
(k (transition #f (quit #f e))))
|
|
||||||
;; transition-accepter : (All (NewState) (Transition NewState) -> Process)
|
|
||||||
(define (transition-accepter t)
|
|
||||||
(match-define (transition initial-state initial-actions) t)
|
|
||||||
(process debug-name
|
|
||||||
new-pid
|
|
||||||
initial-state
|
|
||||||
'()
|
|
||||||
#hash()
|
|
||||||
#hash()
|
|
||||||
(action-tree->quasiqueue initial-actions)))
|
|
||||||
(let ((new-process
|
|
||||||
(send-to-user* debug-name new-pid (e) (transition-accepter (transition #f (quit #f e)))
|
|
||||||
(new-cotransition transition-accepter))))
|
|
||||||
(values (if parent-k
|
|
||||||
(run-ready p (send-to-user p (e) (quit-interruptk e)
|
|
||||||
(parent-k new-pid)))
|
|
||||||
p)
|
|
||||||
(inject-process (struct-copy vm state [next-process-id (+ new-pid 1)])
|
|
||||||
new-process))))
|
|
214
actions.rkt
214
actions.rkt
|
@ -1,214 +0,0 @@
|
||||||
#lang racket/base
|
|
||||||
|
|
||||||
(require racket/match)
|
|
||||||
(require "structs.rkt")
|
|
||||||
(require "roles.rkt")
|
|
||||||
(require "vm.rkt")
|
|
||||||
(require "log.rkt")
|
|
||||||
(require "process.rkt")
|
|
||||||
(require "action-add-endpoint.rkt")
|
|
||||||
(require "action-delete-endpoint.rkt")
|
|
||||||
(require "action-send-message.rkt")
|
|
||||||
(require "action-spawn.rkt")
|
|
||||||
(require "action-quit.rkt")
|
|
||||||
(require "list-utils.rkt")
|
|
||||||
(require "quasiqueue.rkt")
|
|
||||||
|
|
||||||
(provide run-vm)
|
|
||||||
|
|
||||||
;; dump-state : vm -> Any
|
|
||||||
(define (dump-state state)
|
|
||||||
`(vm (next-pid ,(vm-next-process-id state))
|
|
||||||
(processes ,@(for/fold ([acc '()])
|
|
||||||
([pid (in-hash-keys (vm-processes state))])
|
|
||||||
(cons (list pid (let ((wp (hash-ref (vm-processes state) pid)))
|
|
||||||
(let ((p wp))
|
|
||||||
(list (match (process-state p)
|
|
||||||
[(? vm? v) (dump-state v)]
|
|
||||||
[v v])
|
|
||||||
(process-spawn-ks p)
|
|
||||||
(process-endpoints p)
|
|
||||||
(process-meta-endpoints p)
|
|
||||||
(process-pending-actions p))))) acc)))))
|
|
||||||
|
|
||||||
;; run-vm : vm -> (Transition vm)
|
|
||||||
(define (run-vm state)
|
|
||||||
;; for each pid,
|
|
||||||
;; extract the corresponding process.
|
|
||||||
;; run through its work items, collecting external actions.
|
|
||||||
;; put the process back.
|
|
||||||
;; return the new state and the external actions
|
|
||||||
(let next-process ((remaining-pids (hash-keys (vm-processes state)))
|
|
||||||
(state state)
|
|
||||||
(external-actions (empty-quasiqueue)))
|
|
||||||
(match remaining-pids
|
|
||||||
['()
|
|
||||||
(let ((state (collect-dead-processes state))
|
|
||||||
(action-tree (quasiqueue->cons-tree external-actions)))
|
|
||||||
(transition state
|
|
||||||
(if (vm-idle? state)
|
|
||||||
action-tree
|
|
||||||
(cons (yield run-vm) action-tree))))]
|
|
||||||
[(cons pid remaining-pids)
|
|
||||||
(let-values (((state wp) (extract-process state pid)))
|
|
||||||
(if (not wp)
|
|
||||||
(next-process remaining-pids state external-actions)
|
|
||||||
(let ((p wp))
|
|
||||||
(let next-action
|
|
||||||
([remaining-actions (quasiqueue->list (process-pending-actions p))]
|
|
||||||
[p (reset-pending-actions p)]
|
|
||||||
[state state]
|
|
||||||
[external-actions external-actions])
|
|
||||||
(match remaining-actions
|
|
||||||
['()
|
|
||||||
(next-process remaining-pids
|
|
||||||
(inject-process state p)
|
|
||||||
external-actions)]
|
|
||||||
[(cons action remaining-actions)
|
|
||||||
(marketplace-log 'debug
|
|
||||||
"PID ~v (~a) Action: ~v"
|
|
||||||
pid
|
|
||||||
(process-debug-name p)
|
|
||||||
action)
|
|
||||||
(let-values (((p state new-external-actions)
|
|
||||||
(perform-action action p state)))
|
|
||||||
(if p
|
|
||||||
(next-action remaining-actions
|
|
||||||
p
|
|
||||||
state
|
|
||||||
(quasiqueue-append external-actions
|
|
||||||
new-external-actions))
|
|
||||||
(next-process remaining-pids
|
|
||||||
state
|
|
||||||
(quasiqueue-append external-actions
|
|
||||||
new-external-actions))))])))))])))
|
|
||||||
|
|
||||||
;; collect-dead-processes : vm -> vm
|
|
||||||
(define (collect-dead-processes state)
|
|
||||||
;; process-alive? : (All (State) (process State) -> Boolean)
|
|
||||||
(define (process-alive? p)
|
|
||||||
(or (not (null? (process-spawn-ks p)))
|
|
||||||
(positive? (hash-count (process-endpoints p)))
|
|
||||||
(positive? (hash-count (process-meta-endpoints p)))
|
|
||||||
(not (quasiqueue-empty? (process-pending-actions p)))))
|
|
||||||
(struct-copy vm state
|
|
||||||
[processes (for/fold ([processes #hash()])
|
|
||||||
([pid (in-hash-keys (vm-processes state))])
|
|
||||||
(define wp (hash-ref (vm-processes state) pid))
|
|
||||||
(let ((p wp))
|
|
||||||
(if (process-alive? p)
|
|
||||||
(hash-set processes pid wp)
|
|
||||||
(begin (marketplace-log 'info
|
|
||||||
"PID ~v (~a) garbage-collected"
|
|
||||||
pid
|
|
||||||
(process-debug-name p))
|
|
||||||
processes))))]))
|
|
||||||
|
|
||||||
;; vm-idle? : vm -> Boolean
|
|
||||||
;; TODO: simplify
|
|
||||||
(define (vm-idle? state)
|
|
||||||
(andmap (lambda (pid)
|
|
||||||
(define wp (hash-ref (vm-processes state) pid))
|
|
||||||
(let ((p wp))
|
|
||||||
(quasiqueue-empty? (process-pending-actions p))))
|
|
||||||
(hash-keys (vm-processes state))))
|
|
||||||
|
|
||||||
;; perform-action : (All (State) (Action State) (process State) vm
|
|
||||||
;; -> (Values (Option (process State)) vm (QuasiQueue (Action vm))))
|
|
||||||
(define (perform-action action p state)
|
|
||||||
(match action
|
|
||||||
[(at-meta-level preaction)
|
|
||||||
(transform-meta-action preaction p state)]
|
|
||||||
[(yield k)
|
|
||||||
(let ((p (run-ready p k)))
|
|
||||||
(values p state (empty-quasiqueue)))]
|
|
||||||
[(quit maybe-pid reason)
|
|
||||||
(do-quit (or maybe-pid (process-pid p)) reason p state)]
|
|
||||||
[_
|
|
||||||
(define-values (new-p new-state)
|
|
||||||
(match action
|
|
||||||
[(add-endpoint pre-eid role handler)
|
|
||||||
(do-add-endpoint pre-eid role handler p state)]
|
|
||||||
[(delete-endpoint pre-eid reason)
|
|
||||||
(do-delete-endpoint pre-eid reason p state)]
|
|
||||||
[(send-message body orientation)
|
|
||||||
(do-send-message orientation body p state)]
|
|
||||||
[(spawn spec k debug-name)
|
|
||||||
(do-spawn spec k p debug-name state)]))
|
|
||||||
(values new-p
|
|
||||||
new-state
|
|
||||||
(empty-quasiqueue))]))
|
|
||||||
|
|
||||||
;; wrap-trapk : eid -> (Handler vm)
|
|
||||||
(define (((wrap-trapk target-eid) event) state)
|
|
||||||
(match-define (eid pid pre-eid) target-eid)
|
|
||||||
(run-vm
|
|
||||||
(let-values (((state wp) (extract-process state pid)))
|
|
||||||
(if (not wp)
|
|
||||||
state
|
|
||||||
(let ((p wp))
|
|
||||||
(define ep (hash-ref (process-meta-endpoints p) pre-eid always-false))
|
|
||||||
(if (not ep)
|
|
||||||
(inject-process state p)
|
|
||||||
(let ((p (run-ready p (send-to-user p (e) (quit-interruptk e)
|
|
||||||
((endpoint-handler ep) event)))))
|
|
||||||
(inject-process state p))))))))
|
|
||||||
|
|
||||||
;; dispatch-spawn-k : PID Integer -> (TrapK PID vm)
|
|
||||||
(define (((dispatch-spawn-k pid spawn-k-id) new-pid) state)
|
|
||||||
(run-vm
|
|
||||||
(let-values (((state wp) (extract-process state pid)))
|
|
||||||
(if (not wp)
|
|
||||||
state
|
|
||||||
(let ((p wp))
|
|
||||||
(match (assoc spawn-k-id (process-spawn-ks p))
|
|
||||||
[#f
|
|
||||||
(inject-process state p)]
|
|
||||||
[(and entry (cons _ k))
|
|
||||||
(define interruptk (send-to-user p (e) (quit-interruptk e)
|
|
||||||
(k new-pid)))
|
|
||||||
(define p1 (struct-copy process p [spawn-ks (remq entry (process-spawn-ks p))]))
|
|
||||||
(inject-process state (run-ready p1 interruptk))]))))))
|
|
||||||
|
|
||||||
;; transform-meta-action : (All (State) (PreAction State) (process State) vm ->
|
|
||||||
;; (Values (Option (process State)) vm (QuasiQueue (Action vm))))
|
|
||||||
(define (transform-meta-action pa p state)
|
|
||||||
(match pa
|
|
||||||
[(add-endpoint pre-eid role unwrapped-handler)
|
|
||||||
(define new-eid (eid (process-pid p) pre-eid))
|
|
||||||
(values (struct-copy process p
|
|
||||||
[meta-endpoints (hash-set (process-meta-endpoints p)
|
|
||||||
pre-eid
|
|
||||||
(endpoint new-eid
|
|
||||||
role
|
|
||||||
unwrapped-handler))])
|
|
||||||
state
|
|
||||||
(quasiqueue
|
|
||||||
(add-endpoint new-eid
|
|
||||||
role
|
|
||||||
(wrap-trapk new-eid))))]
|
|
||||||
[(delete-endpoint pre-eid reason)
|
|
||||||
(define old-eid (eid (process-pid p) pre-eid))
|
|
||||||
(values (struct-copy process p
|
|
||||||
[meta-endpoints (hash-remove (process-meta-endpoints p) pre-eid)])
|
|
||||||
state
|
|
||||||
(quasiqueue (delete-endpoint old-eid reason)))]
|
|
||||||
[(send-message body orientation)
|
|
||||||
(values p
|
|
||||||
state
|
|
||||||
(quasiqueue (send-message body orientation)))]
|
|
||||||
[(spawn spec k debug-name)
|
|
||||||
(define pid (process-pid p))
|
|
||||||
(if k
|
|
||||||
(let ((spawn-k-id (+ 1 (list-max (map car (process-spawn-ks p))))))
|
|
||||||
(values (struct-copy process p
|
|
||||||
[spawn-ks (cons (cons spawn-k-id k) (process-spawn-ks p))])
|
|
||||||
state
|
|
||||||
(quasiqueue (spawn spec (dispatch-spawn-k pid spawn-k-id) debug-name))))
|
|
||||||
(values p
|
|
||||||
state
|
|
||||||
(quasiqueue (spawn spec #f debug-name))))]
|
|
||||||
[(quit maybe-pid reason)
|
|
||||||
(values p
|
|
||||||
state
|
|
||||||
(quasiqueue (quit maybe-pid reason)))]))
|
|
|
@ -1,27 +0,0 @@
|
||||||
#lang racket/base
|
|
||||||
;; Ground-event relay.
|
|
||||||
|
|
||||||
(provide event-relay)
|
|
||||||
(require "../sugar.rkt")
|
|
||||||
|
|
||||||
;; event-relay : (All (ParentState) Symbol -> (Spawn ParentState))
|
|
||||||
(define (event-relay self-id)
|
|
||||||
(name-process `(event-relay ,self-id)
|
|
||||||
(spawn (transition/no-state
|
|
||||||
(observe-subscribers (cons ? ?)
|
|
||||||
(match-conversation (cons (? evt? e) _)
|
|
||||||
(on-presence (begin
|
|
||||||
(printf "SUBSCRIBED ~v~n" e)
|
|
||||||
(flush-output)
|
|
||||||
(at-meta-level
|
|
||||||
(name-endpoint `(event-relay ,self-id ,e)
|
|
||||||
(subscriber (cons e ?)
|
|
||||||
(on-message
|
|
||||||
[msg (begin (printf "FIRED ~v -> ~v~n" e msg)
|
|
||||||
(flush-output)
|
|
||||||
(send-message msg))]))))))
|
|
||||||
(on-absence (begin
|
|
||||||
(printf "UNSUBSCRIBED ~v~n" e)
|
|
||||||
(flush-output)
|
|
||||||
(at-meta-level
|
|
||||||
(delete-endpoint `(event-relay ,self-id ,e)))))))))))
|
|
|
@ -1,179 +0,0 @@
|
||||||
#lang racket/base
|
|
||||||
;; TCP drivers, ported from os2.rkt directly, with flow-control and line discipline removed
|
|
||||||
|
|
||||||
(require racket/set)
|
|
||||||
(require racket/match)
|
|
||||||
(require (prefix-in tcp: racket/tcp))
|
|
||||||
(require racket/port)
|
|
||||||
(require "../sugar.rkt")
|
|
||||||
(require "../support/dump-bytes.rkt")
|
|
||||||
(require "../unify.rkt")
|
|
||||||
|
|
||||||
(provide (struct-out tcp-address)
|
|
||||||
(struct-out tcp-handle)
|
|
||||||
(struct-out tcp-listener)
|
|
||||||
(struct-out tcp-channel)
|
|
||||||
tcp
|
|
||||||
tcp-driver)
|
|
||||||
|
|
||||||
(struct tcp-address (host port) #:prefab)
|
|
||||||
(struct tcp-handle (id) #:prefab)
|
|
||||||
(struct tcp-listener (port) #:prefab)
|
|
||||||
|
|
||||||
(struct tcp-channel (source destination subpacket) #:prefab)
|
|
||||||
|
|
||||||
(define any-remote (tcp-address (wild) (wild)))
|
|
||||||
(define any-handle (tcp-handle (wild)))
|
|
||||||
(define any-listener (tcp-listener (wild)))
|
|
||||||
|
|
||||||
(define (tcp-driver)
|
|
||||||
(name-process 'tcp-driver
|
|
||||||
(spawn
|
|
||||||
(transition (set)
|
|
||||||
(observe-publishers/everything (tcp-channel any-listener any-remote (wild))
|
|
||||||
(match-state active-handles
|
|
||||||
(match-conversation c
|
|
||||||
(on-presence (maybe-spawn-socket 'publisher c active-handles #f tcp-listener-manager))
|
|
||||||
(on-absence (maybe-forget-socket 'publisher c active-handles)))))
|
|
||||||
(observe-subscribers/everything (tcp-channel any-remote any-listener (wild))
|
|
||||||
(match-state active-handles
|
|
||||||
(match-conversation c
|
|
||||||
(on-presence (maybe-spawn-socket 'subscriber c active-handles #f tcp-listener-manager))
|
|
||||||
(on-absence (maybe-forget-socket 'subscriber c active-handles)))))
|
|
||||||
(observe-publishers (tcp-channel any-handle any-remote (wild))
|
|
||||||
(match-state active-handles
|
|
||||||
(match-conversation c
|
|
||||||
(on-presence
|
|
||||||
(maybe-spawn-socket 'publisher c active-handles #t tcp-connection-manager))
|
|
||||||
(on-absence (maybe-forget-socket 'publisher c active-handles)))))
|
|
||||||
(observe-subscribers (tcp-channel any-remote any-handle (wild))
|
|
||||||
(match-state active-handles
|
|
||||||
(match-conversation c
|
|
||||||
(on-presence
|
|
||||||
(maybe-spawn-socket 'subscriber c active-handles #t tcp-connection-manager))
|
|
||||||
(on-absence (maybe-forget-socket 'subscriber c active-handles)))))))))
|
|
||||||
|
|
||||||
(define tcp (tcp-driver)) ;; pre-instantiated!
|
|
||||||
|
|
||||||
(define (maybe-spawn-socket orientation c active-handles remote-should-be-ground driver-fun)
|
|
||||||
(match (list orientation c)
|
|
||||||
[(or (list 'publisher (tcp-channel local-addr remote-addr _))
|
|
||||||
(list 'subscriber (tcp-channel remote-addr local-addr _)))
|
|
||||||
(cond
|
|
||||||
[(not (eqv? remote-should-be-ground (ground? remote-addr))) (transition active-handles)]
|
|
||||||
[(not (ground? local-addr)) (transition active-handles)]
|
|
||||||
[(set-member? active-handles (cons local-addr remote-addr)) (transition active-handles)]
|
|
||||||
[else
|
|
||||||
(transition (set-add active-handles (cons local-addr remote-addr))
|
|
||||||
(name-process (cons local-addr remote-addr)
|
|
||||||
(spawn (driver-fun local-addr remote-addr))))])]))
|
|
||||||
|
|
||||||
;; Orientation Topic Set<HandleMapping> -> Transition
|
|
||||||
(define (maybe-forget-socket orientation c active-handles)
|
|
||||||
(match (list orientation c)
|
|
||||||
[(or (list 'publisher (tcp-channel local-addr remote-addr _))
|
|
||||||
(list 'subscriber (tcp-channel remote-addr local-addr _)))
|
|
||||||
(cond
|
|
||||||
[(ground? remote-addr) (transition active-handles)]
|
|
||||||
[(not (ground? local-addr)) (transition active-handles)]
|
|
||||||
[else (transition (set-remove active-handles (cons local-addr remote-addr)))])]))
|
|
||||||
|
|
||||||
;; TcpAddress TcpAddress -> Transition
|
|
||||||
(define (tcp-listener-manager local-addr dummy-remote-addr)
|
|
||||||
(match-define (tcp-listener port) local-addr)
|
|
||||||
(define listener (tcp:tcp-listen port 4 #t))
|
|
||||||
|
|
||||||
(define (handle-absence orientation c state)
|
|
||||||
;; Hey, what if the presence we need went away between our manager
|
|
||||||
;; spawning us, and us getting to this point? Presence being
|
|
||||||
;; "edge-" rather than "level-triggered" means we'll hang around
|
|
||||||
;; sadly forever, accepting connections to nowhere. TODO
|
|
||||||
(match (list orientation c)
|
|
||||||
[(or (list 'publisher (tcp-channel (== local-addr) remote-addr _))
|
|
||||||
(list 'subscriber (tcp-channel remote-addr (== local-addr) _)))
|
|
||||||
(if (ground? remote-addr)
|
|
||||||
(transition state)
|
|
||||||
(transition 'listener-is-closed
|
|
||||||
(quit)
|
|
||||||
(when (eq? state 'listener-is-running)
|
|
||||||
(name-process (list 'tcp-listener-closer local-addr)
|
|
||||||
(spawn (begin (tcp:tcp-close listener)
|
|
||||||
(transition 'dummy (quit))))))))]))
|
|
||||||
|
|
||||||
(transition 'listener-is-running
|
|
||||||
(observe-publishers/everything (tcp-channel local-addr any-remote (wild))
|
|
||||||
(match-state state
|
|
||||||
(match-conversation c
|
|
||||||
(on-absence (handle-absence 'publisher c state)))))
|
|
||||||
(observe-subscribers/everything (tcp-channel any-remote local-addr (wild))
|
|
||||||
(match-state state
|
|
||||||
(match-conversation c
|
|
||||||
(on-absence (handle-absence 'subscriber c state)))))
|
|
||||||
(subscriber (cons (tcp:tcp-accept-evt listener) (wild))
|
|
||||||
(on-message
|
|
||||||
[(cons _ (list cin cout))
|
|
||||||
(let-values (((local-hostname local-port remote-hostname remote-port)
|
|
||||||
(tcp:tcp-addresses cin #t)))
|
|
||||||
(define remote-addr (tcp-address remote-hostname remote-port))
|
|
||||||
(name-process (cons local-addr remote-addr)
|
|
||||||
(spawn (tcp-connection-manager* local-addr remote-addr cin cout))))]))))
|
|
||||||
|
|
||||||
;; TcpAddress TcpAddress -> Transition
|
|
||||||
(define (tcp-connection-manager local-addr remote-addr)
|
|
||||||
(match-define (tcp-address remote-hostname remote-port) remote-addr)
|
|
||||||
(define-values (cin cout) (tcp:tcp-connect remote-hostname remote-port))
|
|
||||||
(tcp-connection-manager* local-addr remote-addr cin cout))
|
|
||||||
|
|
||||||
(define (read-bytes-avail-evt len input-port)
|
|
||||||
(guard-evt
|
|
||||||
(lambda ()
|
|
||||||
(let ([bstr (make-bytes len)])
|
|
||||||
(wrap-evt
|
|
||||||
(read-bytes-avail!-evt bstr input-port)
|
|
||||||
(lambda (v)
|
|
||||||
(if (number? v)
|
|
||||||
(if (= v len) bstr (subbytes bstr 0 v))
|
|
||||||
v)))))))
|
|
||||||
|
|
||||||
;; TcpAddress TcpAddress InputPort OutputPort -> Transition
|
|
||||||
;;
|
|
||||||
;; Our process state here is a Maybe<TcpConnectionState>, representing
|
|
||||||
;; a shutting-down state if #f.
|
|
||||||
(define (tcp-connection-manager* local-addr remote-addr cin cout)
|
|
||||||
(define (close-transition is-open send-eof?)
|
|
||||||
(transition #f
|
|
||||||
(when is-open
|
|
||||||
(list (when send-eof?
|
|
||||||
(send-message (tcp-channel remote-addr local-addr eof)))
|
|
||||||
(name-process (list 'tcp-connection-closer local-addr remote-addr)
|
|
||||||
(spawn (begin (tcp:tcp-abandon-port cin)
|
|
||||||
(tcp:tcp-abandon-port cout)
|
|
||||||
(transition/no-state (quit)))))))
|
|
||||||
(quit)))
|
|
||||||
|
|
||||||
(transition #t ;; open
|
|
||||||
(subscriber (cons (read-bytes-avail-evt 4096 cin) (wild))
|
|
||||||
(match-state is-open
|
|
||||||
(on-message
|
|
||||||
[(cons _ (? eof-object?)) (close-transition is-open #t)]
|
|
||||||
[(cons _ (? bytes? bs)) (transition is-open
|
|
||||||
(send-message (tcp-channel remote-addr local-addr bs)))])))
|
|
||||||
(subscriber (cons (eof-evt cin) (wild))
|
|
||||||
(match-state is-open
|
|
||||||
(on-message [(cons (? evt?) _) (close-transition is-open #t)])))
|
|
||||||
(subscriber (tcp-channel local-addr remote-addr (wild))
|
|
||||||
(match-state is-open
|
|
||||||
(on-absence (close-transition is-open #f))
|
|
||||||
(on-message
|
|
||||||
[(tcp-channel (== local-addr) (== remote-addr) subpacket)
|
|
||||||
(match subpacket
|
|
||||||
[(? eof-object?) (close-transition is-open #f)]
|
|
||||||
[(? string? s) (begin (write-string s cout)
|
|
||||||
(flush-output cout)
|
|
||||||
(transition is-open))]
|
|
||||||
[(? bytes? bs) (begin (write-bytes bs cout)
|
|
||||||
(flush-output cout)
|
|
||||||
(transition is-open))])])))
|
|
||||||
(publisher (tcp-channel remote-addr local-addr (wild))
|
|
||||||
(match-state is-open
|
|
||||||
(on-absence (close-transition is-open #f))))))
|
|
|
@ -1,157 +0,0 @@
|
||||||
#lang racket/base
|
|
||||||
;; TCP driver, with flow-control and line discipline removed, sans reliance on (ground?)
|
|
||||||
|
|
||||||
(require racket/set)
|
|
||||||
(require racket/match)
|
|
||||||
(require (prefix-in tcp: racket/tcp))
|
|
||||||
(require racket/port)
|
|
||||||
(require "../sugar.rkt")
|
|
||||||
(require "../support/dump-bytes.rkt")
|
|
||||||
|
|
||||||
(provide (struct-out tcp-address)
|
|
||||||
(struct-out tcp-handle)
|
|
||||||
(struct-out tcp-listener)
|
|
||||||
(struct-out tcp-channel)
|
|
||||||
tcp
|
|
||||||
tcp-driver)
|
|
||||||
|
|
||||||
(struct tcp-address (host port) #:prefab)
|
|
||||||
(struct tcp-handle (id) #:prefab)
|
|
||||||
(struct tcp-listener (port) #:prefab)
|
|
||||||
|
|
||||||
(struct tcp-channel (source destination subpacket) #:prefab)
|
|
||||||
|
|
||||||
(define any-remote (tcp-address (wild) (wild)))
|
|
||||||
(define any-handle (tcp-handle (wild)))
|
|
||||||
(define any-listener (tcp-listener (wild)))
|
|
||||||
|
|
||||||
(define (tcp-driver)
|
|
||||||
(name-process 'tcp-driver
|
|
||||||
(spawn
|
|
||||||
(transition (set)
|
|
||||||
(observe-publishers/everything (tcp-channel any-listener any-remote (wild))
|
|
||||||
(match-interest-type 'observer
|
|
||||||
(match-state active-handles
|
|
||||||
(match-conversation (tcp-channel L _ _)
|
|
||||||
(on-presence (maybe-spawn-socket 'incoming L active-handles tcp-listener-manager))
|
|
||||||
(on-absence (maybe-forget-socket 'incoming L active-handles))))))
|
|
||||||
(observe-subscribers/everything (tcp-channel any-remote any-listener (wild))
|
|
||||||
(match-interest-type 'observer
|
|
||||||
(match-state active-handles
|
|
||||||
(match-conversation (tcp-channel _ L _)
|
|
||||||
(on-presence (maybe-spawn-socket 'incoming L active-handles tcp-listener-manager))
|
|
||||||
(on-absence (maybe-forget-socket 'incoming L active-handles))))))
|
|
||||||
(observe-publishers (tcp-channel any-handle any-remote (wild))
|
|
||||||
(match-state active-handles
|
|
||||||
(match-conversation (tcp-channel L R _)
|
|
||||||
(on-presence (maybe-spawn-socket R L active-handles tcp-connection-manager))
|
|
||||||
(on-absence (maybe-forget-socket R L active-handles)))))
|
|
||||||
(observe-subscribers (tcp-channel any-remote any-handle (wild))
|
|
||||||
(match-state active-handles
|
|
||||||
(match-conversation (tcp-channel R L _)
|
|
||||||
(on-presence (maybe-spawn-socket R L active-handles tcp-connection-manager))
|
|
||||||
(on-absence (maybe-forget-socket R L active-handles)))))))))
|
|
||||||
|
|
||||||
(define tcp (tcp-driver)) ;; pre-instantiated!
|
|
||||||
|
|
||||||
(define (maybe-spawn-socket R L active-handles driver-fun)
|
|
||||||
(define name (cons L R))
|
|
||||||
(if (set-member? active-handles name)
|
|
||||||
(transition active-handles)
|
|
||||||
(transition (set-add active-handles name)
|
|
||||||
(name-process name (spawn (driver-fun L R))))))
|
|
||||||
|
|
||||||
(define (maybe-forget-socket R L active-handles)
|
|
||||||
(define name (cons L R))
|
|
||||||
(transition (set-remove active-handles name)))
|
|
||||||
|
|
||||||
;; TcpAddress 'incoming -> Transition
|
|
||||||
(define (tcp-listener-manager local-addr dummy-incoming-marker)
|
|
||||||
(match-define (tcp-listener port) local-addr)
|
|
||||||
(define listener (tcp:tcp-listen port 4 #t))
|
|
||||||
|
|
||||||
(define (handle-absence)
|
|
||||||
;; Hey, what if the presence we need went away between our manager
|
|
||||||
;; spawning us, and us getting to this point? Presence being
|
|
||||||
;; "edge-" rather than "level-triggered" means we'll hang around
|
|
||||||
;; sadly forever, accepting connections to nowhere. TODO
|
|
||||||
(transition 'listener-is-closed
|
|
||||||
(name-process (list 'tcp-listener-closer local-addr)
|
|
||||||
(spawn (begin (tcp:tcp-close listener)
|
|
||||||
(transition 'dummy (quit)))))
|
|
||||||
(quit)))
|
|
||||||
|
|
||||||
(transition 'listener-is-running
|
|
||||||
(observe-publishers/everything (tcp-channel local-addr any-remote (wild))
|
|
||||||
(match-interest-type 'observer
|
|
||||||
(match-state 'listener-is-running
|
|
||||||
(on-absence (handle-absence)))))
|
|
||||||
(observe-subscribers/everything (tcp-channel any-remote local-addr (wild))
|
|
||||||
(match-interest-type 'observer
|
|
||||||
(match-state 'listener-is-running
|
|
||||||
(on-absence (handle-absence)))))
|
|
||||||
(subscriber (cons (tcp:tcp-accept-evt listener) (wild))
|
|
||||||
(on-message
|
|
||||||
[(cons _ (list cin cout))
|
|
||||||
(let-values (((local-hostname local-port remote-hostname remote-port)
|
|
||||||
(tcp:tcp-addresses cin #t)))
|
|
||||||
(define remote-addr (tcp-address remote-hostname remote-port))
|
|
||||||
(name-process (cons local-addr remote-addr)
|
|
||||||
(spawn (tcp-connection-manager* local-addr remote-addr cin cout))))]))))
|
|
||||||
|
|
||||||
;; TcpAddress TcpAddress -> Transition
|
|
||||||
(define (tcp-connection-manager local-addr remote-addr)
|
|
||||||
(match-define (tcp-address remote-hostname remote-port) remote-addr)
|
|
||||||
(define-values (cin cout) (tcp:tcp-connect remote-hostname remote-port))
|
|
||||||
(tcp-connection-manager* local-addr remote-addr cin cout))
|
|
||||||
|
|
||||||
(define (read-bytes-avail-evt len input-port)
|
|
||||||
(guard-evt
|
|
||||||
(lambda ()
|
|
||||||
(let ([bstr (make-bytes len)])
|
|
||||||
(wrap-evt
|
|
||||||
(read-bytes-avail!-evt bstr input-port)
|
|
||||||
(lambda (v)
|
|
||||||
(if (number? v)
|
|
||||||
(if (= v len) bstr (subbytes bstr 0 v))
|
|
||||||
v)))))))
|
|
||||||
|
|
||||||
;; TcpAddress TcpAddress InputPort OutputPort -> Transition
|
|
||||||
;;
|
|
||||||
;; Our process state here is either 'open or 'closing.
|
|
||||||
(define (tcp-connection-manager* local-addr remote-addr cin cout)
|
|
||||||
(define (close-transition send-eof?)
|
|
||||||
(transition 'closing
|
|
||||||
(when send-eof? (send-message (tcp-channel remote-addr local-addr eof)))
|
|
||||||
(name-process (list 'tcp-connection-closer local-addr remote-addr)
|
|
||||||
(spawn (begin (tcp:tcp-abandon-port cin)
|
|
||||||
(tcp:tcp-abandon-port cout)
|
|
||||||
(transition/no-state (quit)))))
|
|
||||||
(quit)))
|
|
||||||
|
|
||||||
(transition 'open
|
|
||||||
(subscriber (cons (read-bytes-avail-evt 4096 cin) (wild))
|
|
||||||
(match-state 'open
|
|
||||||
(on-message
|
|
||||||
[(cons _ (? eof-object?)) (close-transition #t)]
|
|
||||||
[(cons _ (? bytes? bs)) (transition 'open
|
|
||||||
(send-message (tcp-channel remote-addr local-addr bs)))])))
|
|
||||||
(subscriber (cons (eof-evt cin) (wild))
|
|
||||||
(match-state 'open
|
|
||||||
(on-message [(cons (? evt?) _) (close-transition #t)])))
|
|
||||||
(subscriber (tcp-channel local-addr remote-addr (wild))
|
|
||||||
(match-state 'open
|
|
||||||
(on-absence (close-transition #f))
|
|
||||||
(on-message
|
|
||||||
[(tcp-channel (== local-addr) (== remote-addr) subpacket)
|
|
||||||
(match subpacket
|
|
||||||
[(? eof-object?) (close-transition #f)]
|
|
||||||
[(? string? s) (begin (write-string s cout)
|
|
||||||
(flush-output cout)
|
|
||||||
(transition 'open))]
|
|
||||||
[(? bytes? bs) (begin (write-bytes bs cout)
|
|
||||||
(flush-output cout)
|
|
||||||
(transition 'open))])])))
|
|
||||||
(publisher (tcp-channel remote-addr local-addr (wild))
|
|
||||||
(match-state 'open
|
|
||||||
(on-absence (close-transition #f))))))
|
|
285
drivers/tcp.rkt
285
drivers/tcp.rkt
|
@ -1,285 +0,0 @@
|
||||||
#lang racket/base
|
|
||||||
;; TCP drivers, ported from os2.rkt directly
|
|
||||||
|
|
||||||
(require racket/set)
|
|
||||||
(require racket/match)
|
|
||||||
(require (prefix-in tcp: racket/tcp))
|
|
||||||
(require racket/port)
|
|
||||||
(require "../sugar.rkt")
|
|
||||||
(require "../support/dump-bytes.rkt")
|
|
||||||
(require "../unify.rkt")
|
|
||||||
|
|
||||||
(provide (struct-out tcp-address)
|
|
||||||
(struct-out tcp-handle)
|
|
||||||
(struct-out tcp-listener)
|
|
||||||
|
|
||||||
(struct-out tcp-channel)
|
|
||||||
(struct-out tcp-credit)
|
|
||||||
(struct-out tcp-mode)
|
|
||||||
send-tcp-credit
|
|
||||||
send-tcp-mode
|
|
||||||
|
|
||||||
tcp-driver
|
|
||||||
tcp-spy)
|
|
||||||
|
|
||||||
;; A TcpAddress is one of
|
|
||||||
;; -- a (tcp-address String Uint16), representing a remote socket
|
|
||||||
;; -- a (tcp-handle Any), representing a local socket on a kernel-assigned port
|
|
||||||
;; -- a (tcp-listener Uint16), representing a local socket on a user-assigned port
|
|
||||||
;; Note that tcp-handle-ids must be chosen carefully: they are scoped
|
|
||||||
;; to the local VM, i.e. shared between processes in that VM, so
|
|
||||||
;; processes must make sure not to accidentally clash in handle ID
|
|
||||||
;; selection. They are also used in TcpChannel to mean a specific
|
|
||||||
;; *instance* of a TCP connection, so if you are likely to want to
|
|
||||||
;; reconnect individual flows, use different tcp-handle-ids.
|
|
||||||
(struct tcp-address (host port) #:prefab)
|
|
||||||
(struct tcp-handle (id) #:prefab)
|
|
||||||
(struct tcp-listener (port) #:prefab)
|
|
||||||
|
|
||||||
;; A TcpChannel is a (tcp-channel TcpAddress TcpAddress TcpSubPacket),
|
|
||||||
;; and represents a section of a unidirectional TCP flow appearing on
|
|
||||||
;; our local "subnet" of the full TCP network, complete with source,
|
|
||||||
;; destination and subpacket.
|
|
||||||
(struct tcp-channel (source destination subpacket) #:prefab)
|
|
||||||
|
|
||||||
;; A TcpSubPacket is either
|
|
||||||
;; -- a Bytes, representing a section of the data carried by a
|
|
||||||
;; TcpChannel. In principle, this should also have a sequence
|
|
||||||
;; number field, but for simplicity we rely on os2.rkt's
|
|
||||||
;; preservation of ordering.
|
|
||||||
;; -- an EndOfFile, representing the end of a the channel's stream.
|
|
||||||
;; -- a (tcp-credit NonNegativeInteger), for flow control.
|
|
||||||
;; -- a (tcp-mode TcpModeName), for mode selection.
|
|
||||||
(struct tcp-credit (amount) #:prefab)
|
|
||||||
(struct tcp-mode (name) #:prefab)
|
|
||||||
|
|
||||||
;; A TcpModeName is either
|
|
||||||
;; -- 'lines, for reading line-at-a-time, or
|
|
||||||
;; -- 'bytes, for reading chunks of bytes.
|
|
||||||
|
|
||||||
;; TODO: BUG?: Routing packets between two local sockets won't work
|
|
||||||
;; because the patterns aren't set up to recognise that situation.
|
|
||||||
|
|
||||||
;; A TcpConnectionState is a (tcp-connection-state TcpModeName
|
|
||||||
;; Integer), representing the current input mode and issued credit.
|
|
||||||
(struct tcp-connection-state (mode credit) #:prefab)
|
|
||||||
|
|
||||||
;; TcpAddress TcpAddress NonNegativeInteger -> Preaction
|
|
||||||
;; Sends a credit message on a channel using the correct (subscriber) role.
|
|
||||||
(define (send-tcp-credit source-addr sink-addr amount)
|
|
||||||
(send-feedback (tcp-channel source-addr sink-addr (tcp-credit amount))))
|
|
||||||
|
|
||||||
;; TcpAddress TcpAddress TcpModeName -> Preaction
|
|
||||||
;; Sends a mode selection message on a channel using the correct (subscriber) role.
|
|
||||||
(define (send-tcp-mode source-addr sink-addr mode-name)
|
|
||||||
(send-feedback (tcp-channel source-addr sink-addr (tcp-mode mode-name))))
|
|
||||||
|
|
||||||
;; TcpAddresses; represents various wildcard addresses
|
|
||||||
(define any-remote (tcp-address (wild) (wild)))
|
|
||||||
(define any-handle (tcp-handle (wild)))
|
|
||||||
(define any-listener (tcp-listener (wild)))
|
|
||||||
|
|
||||||
;; Spawn
|
|
||||||
;; Process acting as a TCP socket factory.
|
|
||||||
(define (tcp-driver)
|
|
||||||
(name-process 'tcp-driver
|
|
||||||
(spawn
|
|
||||||
(transition (set)
|
|
||||||
(observe-publishers/everything (tcp-channel any-listener any-remote (wild))
|
|
||||||
(match-state active-handles
|
|
||||||
(match-conversation c
|
|
||||||
(on-presence (maybe-spawn-socket 'publisher c active-handles #f tcp-listener-manager))
|
|
||||||
(on-absence (maybe-forget-socket 'publisher c active-handles)))))
|
|
||||||
(observe-subscribers/everything (tcp-channel any-remote any-listener (wild))
|
|
||||||
(match-state active-handles
|
|
||||||
(match-conversation c
|
|
||||||
(on-presence (maybe-spawn-socket 'subscriber c active-handles #f tcp-listener-manager))
|
|
||||||
(on-absence (maybe-forget-socket 'subscriber c active-handles)))))
|
|
||||||
(observe-publishers (tcp-channel any-handle any-remote (wild))
|
|
||||||
(match-state active-handles
|
|
||||||
(match-conversation c
|
|
||||||
(on-presence
|
|
||||||
(maybe-spawn-socket 'publisher c active-handles #t tcp-connection-manager))
|
|
||||||
(on-absence (maybe-forget-socket 'publisher c active-handles)))))
|
|
||||||
(observe-subscribers (tcp-channel any-remote any-handle (wild))
|
|
||||||
(match-state active-handles
|
|
||||||
(match-conversation c
|
|
||||||
(on-presence
|
|
||||||
(maybe-spawn-socket 'subscriber c active-handles #t tcp-connection-manager))
|
|
||||||
(on-absence (maybe-forget-socket 'subscriber c active-handles)))))))))
|
|
||||||
|
|
||||||
;; Orientation Topic Set<HandleMapping> Boolean (TcpAddress TcpAddress -> BootK) -> Transition
|
|
||||||
(define (maybe-spawn-socket orientation c active-handles remote-should-be-ground driver-fun)
|
|
||||||
(match (list orientation c)
|
|
||||||
[(or (list 'publisher (tcp-channel local-addr remote-addr _))
|
|
||||||
(list 'subscriber (tcp-channel remote-addr local-addr _)))
|
|
||||||
(cond
|
|
||||||
[(not (eqv? remote-should-be-ground (ground? remote-addr))) (transition active-handles)]
|
|
||||||
[(not (ground? local-addr)) (transition active-handles)]
|
|
||||||
[(set-member? active-handles (cons local-addr remote-addr)) (transition active-handles)]
|
|
||||||
[else
|
|
||||||
(transition (set-add active-handles (cons local-addr remote-addr))
|
|
||||||
(name-process (cons local-addr remote-addr)
|
|
||||||
(spawn (driver-fun local-addr remote-addr))))])]))
|
|
||||||
|
|
||||||
;; Orientation Topic Set<HandleMapping> -> Transition
|
|
||||||
(define (maybe-forget-socket orientation c active-handles)
|
|
||||||
(match (list orientation c)
|
|
||||||
[(or (list 'publisher (tcp-channel local-addr remote-addr _))
|
|
||||||
(list 'subscriber (tcp-channel remote-addr local-addr _)))
|
|
||||||
(cond
|
|
||||||
[(ground? remote-addr) (transition active-handles)]
|
|
||||||
[(not (ground? local-addr)) (transition active-handles)]
|
|
||||||
[else (transition (set-remove active-handles (cons local-addr remote-addr)))])]))
|
|
||||||
|
|
||||||
;; TcpAddress TcpAddress -> Transition
|
|
||||||
(define (tcp-listener-manager local-addr dummy-remote-addr)
|
|
||||||
(match-define (tcp-listener port) local-addr)
|
|
||||||
(define listener (tcp:tcp-listen port 4 #t))
|
|
||||||
|
|
||||||
(define (handle-absence orientation c state)
|
|
||||||
;; Hey, what if the presence we need went away between our manager
|
|
||||||
;; spawning us, and us getting to this point? Presence being
|
|
||||||
;; "edge-" rather than "level-triggered" means we'll hang around
|
|
||||||
;; sadly forever, accepting connections to nowhere. TODO
|
|
||||||
(match (list orientation c)
|
|
||||||
[(or (list 'publisher (tcp-channel (== local-addr) remote-addr _))
|
|
||||||
(list 'subscriber (tcp-channel remote-addr (== local-addr) _)))
|
|
||||||
(if (ground? remote-addr)
|
|
||||||
(transition state)
|
|
||||||
(transition 'listener-is-closed
|
|
||||||
(quit)
|
|
||||||
(when (eq? state 'listener-is-running)
|
|
||||||
(name-process (list 'tcp-listener-closer local-addr)
|
|
||||||
(spawn (begin (tcp:tcp-close listener)
|
|
||||||
(transition 'dummy (quit))))))))]))
|
|
||||||
|
|
||||||
(transition 'listener-is-running
|
|
||||||
(observe-publishers/everything (tcp-channel local-addr any-remote (wild))
|
|
||||||
(match-state state
|
|
||||||
(match-conversation c
|
|
||||||
(on-absence (handle-absence 'publisher c state)))))
|
|
||||||
(observe-subscribers/everything (tcp-channel any-remote local-addr (wild))
|
|
||||||
(match-state state
|
|
||||||
(match-conversation c
|
|
||||||
(on-absence (handle-absence 'subscriber c state)))))
|
|
||||||
(subscriber (cons (tcp:tcp-accept-evt listener) (wild))
|
|
||||||
(on-message
|
|
||||||
[(cons _ (list cin cout))
|
|
||||||
(let-values (((local-hostname local-port remote-hostname remote-port)
|
|
||||||
(tcp:tcp-addresses cin #t)))
|
|
||||||
(define remote-addr (tcp-address remote-hostname remote-port))
|
|
||||||
(name-process (cons local-addr remote-addr)
|
|
||||||
(spawn (tcp-connection-manager* local-addr remote-addr cin cout))))]))))
|
|
||||||
|
|
||||||
;; TcpAddress TcpAddress -> Transition
|
|
||||||
(define (tcp-connection-manager local-addr remote-addr)
|
|
||||||
(match-define (tcp-address remote-hostname remote-port) remote-addr)
|
|
||||||
(define-values (cin cout) (tcp:tcp-connect remote-hostname remote-port))
|
|
||||||
(tcp-connection-manager* local-addr remote-addr cin cout))
|
|
||||||
|
|
||||||
;; TcpAddress TcpAddress InputPort OutputPort -> Transition
|
|
||||||
;;
|
|
||||||
;; Our process state here is a Maybe<TcpConnectionState>, representing
|
|
||||||
;; a shutting-down state if #f.
|
|
||||||
(define (tcp-connection-manager* local-addr remote-addr cin cout)
|
|
||||||
(define (close-transition state send-eof?)
|
|
||||||
(transition #f
|
|
||||||
(when (not (eq? state #f))
|
|
||||||
(list (when send-eof?
|
|
||||||
(send-message (tcp-channel remote-addr local-addr eof)))
|
|
||||||
(name-process (list 'tcp-connection-closer local-addr remote-addr)
|
|
||||||
(spawn(begin (tcp:tcp-abandon-port cin)
|
|
||||||
(tcp:tcp-abandon-port cout)
|
|
||||||
(transition 'dummy (quit)))))))
|
|
||||||
(quit)))
|
|
||||||
(define (adjust-credit state amount)
|
|
||||||
(let ((new-credit (+ (tcp-connection-state-credit state) amount)))
|
|
||||||
(transition (struct-copy tcp-connection-state state [credit new-credit])
|
|
||||||
(delete-endpoint 'inbound-relay)
|
|
||||||
(when (positive? new-credit)
|
|
||||||
(case (tcp-connection-state-mode state)
|
|
||||||
[(lines)
|
|
||||||
(name-endpoint 'inbound-relay
|
|
||||||
(subscriber (cons (read-bytes-line-evt cin 'any) (wild))
|
|
||||||
(match-state state
|
|
||||||
(on-message
|
|
||||||
[(cons _ (? eof-object?))
|
|
||||||
(close-transition state #t)]
|
|
||||||
[(cons _ (? bytes? bs))
|
|
||||||
(sequence-actions (adjust-credit state -1)
|
|
||||||
(send-message (tcp-channel remote-addr local-addr bs)))]))))]
|
|
||||||
[(bytes)
|
|
||||||
(name-endpoint 'inbound-relay
|
|
||||||
(subscriber (cons (read-bytes-evt new-credit cin) (wild))
|
|
||||||
(match-state state
|
|
||||||
(on-message
|
|
||||||
[(cons _ (? eof-object?))
|
|
||||||
(close-transition state #t)]
|
|
||||||
[(cons _ (? bytes? bs))
|
|
||||||
(let ((len (bytes-length bs)))
|
|
||||||
(sequence-actions (adjust-credit state (- len))
|
|
||||||
(send-message
|
|
||||||
(tcp-channel remote-addr local-addr bs))))]))))])))))
|
|
||||||
(transition (tcp-connection-state 'bytes 0)
|
|
||||||
(subscriber (cons (eof-evt cin) (wild))
|
|
||||||
(match-state state
|
|
||||||
(on-message
|
|
||||||
[(cons (? evt?) _)
|
|
||||||
(close-transition state #t)])))
|
|
||||||
(subscriber (tcp-channel local-addr remote-addr (wild))
|
|
||||||
(match-state state
|
|
||||||
(on-absence (close-transition state #f))
|
|
||||||
(on-message
|
|
||||||
[(tcp-channel (== local-addr) (== remote-addr) subpacket)
|
|
||||||
(match subpacket
|
|
||||||
[(? eof-object?) (close-transition state #f)]
|
|
||||||
[(? bytes? bs)
|
|
||||||
(define len (bytes-length bs))
|
|
||||||
(write-bytes bs cout)
|
|
||||||
(flush-output cout)
|
|
||||||
(transition state (send-tcp-credit local-addr remote-addr len))]
|
|
||||||
[_
|
|
||||||
(error 'tcp-connection-manager*
|
|
||||||
"Publisher on a channel isn't supposed to issue channel control messages")])])))
|
|
||||||
(publisher (tcp-channel remote-addr local-addr (wild))
|
|
||||||
(match-state state
|
|
||||||
(on-absence (close-transition state #f))
|
|
||||||
(on-message
|
|
||||||
[(tcp-channel (== remote-addr) (== local-addr) subpacket)
|
|
||||||
(match subpacket
|
|
||||||
[(tcp-credit amount)
|
|
||||||
(if state (adjust-credit state amount) (transition state))]
|
|
||||||
[(tcp-mode new-mode)
|
|
||||||
;; Also resets credit to zero.
|
|
||||||
(if state (adjust-credit (tcp-connection-state new-mode 0) 0) (transition state))]
|
|
||||||
[_
|
|
||||||
(error 'tcp-connection-manager*
|
|
||||||
"Subscriber on a channel may only send channel control messages")])])))))
|
|
||||||
|
|
||||||
;; Spawn
|
|
||||||
;; Debugging aid: produces pretty hex dumps of TCP traffic sent on
|
|
||||||
;; this network. Also prints out other messages without special
|
|
||||||
;; formatting.
|
|
||||||
(define (tcp-spy)
|
|
||||||
|
|
||||||
(define (display-message m)
|
|
||||||
(match m
|
|
||||||
[(tcp-channel source dest (? bytes? body))
|
|
||||||
(write `(TCPDATA ,source --> ,dest)) (newline)
|
|
||||||
(dump-bytes! body (bytes-length body))
|
|
||||||
(void)]
|
|
||||||
[(tcp-channel source dest (? eof-object?))
|
|
||||||
(write `(TCPEOF ,source --> ,dest)) (newline)
|
|
||||||
(void)]
|
|
||||||
[(tcp-channel source dest (tcp-credit amount))
|
|
||||||
(write `(TCPCREDIT ,source --> ,dest ,amount)) (newline)
|
|
||||||
(void)]
|
|
||||||
[other
|
|
||||||
(write `(TCPOTHER ,other)) (newline)
|
|
||||||
(void)]))
|
|
||||||
|
|
||||||
(name-process 'tcp-spy
|
|
||||||
(spawn (transition 'no-state
|
|
||||||
(observe-publishers (wild) (on-message [m (display-message m)]))
|
|
||||||
(observe-subscribers (wild) (on-message [m (display-message m)]))))))
|
|
|
@ -1,154 +0,0 @@
|
||||||
#lang racket/base
|
|
||||||
;; Timer driver.
|
|
||||||
|
|
||||||
;; Uses mutable state internally, but because the scope of the
|
|
||||||
;; mutation is limited to each timer process alone, it's easy to show
|
|
||||||
;; correct linear use of the various pointers.
|
|
||||||
|
|
||||||
(require racket/set)
|
|
||||||
(require racket/match)
|
|
||||||
(require data/heap)
|
|
||||||
(require "../sugar.rkt")
|
|
||||||
|
|
||||||
;; (pending-timer AbsoluteSeconds Any Boolean)
|
|
||||||
;; An outstanding timer being managed by the timer-driver.
|
|
||||||
(struct pending-timer (deadline ;; Real
|
|
||||||
label ;; TimerLabel
|
|
||||||
)
|
|
||||||
#:transparent)
|
|
||||||
|
|
||||||
(provide (struct-out set-timer)
|
|
||||||
(struct-out timer-expired)
|
|
||||||
timer-driver
|
|
||||||
timer-relay)
|
|
||||||
|
|
||||||
;; (define-type TimerKind (U 'relative 'absolute))
|
|
||||||
|
|
||||||
;; The timer driver and timer relays listen for messages of this type,
|
|
||||||
;; and when they hear one, they set an alarm that will later send a
|
|
||||||
;; corresponding timer-expired message.
|
|
||||||
(struct set-timer (label msecs kind) #:transparent)
|
|
||||||
|
|
||||||
;; Message sent by the timer driver or a timer relay upon expiry of a
|
|
||||||
;; timer. Contains the label specified in the corresponding set-timer
|
|
||||||
;; message, and also the current absolute time from the outside world.
|
|
||||||
(struct timer-expired (label msecs) #:transparent)
|
|
||||||
|
|
||||||
;; State of a timer-driver, including the identifier of the driver,
|
|
||||||
;; the currently-active subscription to ground time events (if any),
|
|
||||||
;; and the heap of all remaining timers.
|
|
||||||
(struct driver-state (heap) #:transparent)
|
|
||||||
|
|
||||||
;; (define-type RelayKey Exact-Nonnegative-Integer)
|
|
||||||
|
|
||||||
;; State of a timer-relay, including the next timer number and a
|
|
||||||
;; mapping from timer number to timer label.
|
|
||||||
(struct relay-state (next-counter ;; RelayKey
|
|
||||||
active-timers ;; (HashTable RelayKey TimerLabel)
|
|
||||||
)
|
|
||||||
#:transparent)
|
|
||||||
|
|
||||||
;; (define-type RelayState relay-state)
|
|
||||||
|
|
||||||
;; Note that (set-timer 'current-time 0 #f) causes an immediate reply
|
|
||||||
;; of (timer-expired 'current-time (current-inexact-milliseconds)),
|
|
||||||
;; which can be used for an event-oriented interface to reading the
|
|
||||||
;; system clock.
|
|
||||||
|
|
||||||
;; Racket's alarm-evt is almost the right design for timeouts: its
|
|
||||||
;; synchronisation value should be the (or some) value of the clock
|
|
||||||
;; after the asked-for time. That way it serves as timeout and
|
|
||||||
;; clock-reader in one.
|
|
||||||
;; timer-evt : Real -> Evt
|
|
||||||
(define (timer-evt msecs)
|
|
||||||
(wrap-evt (alarm-evt msecs)
|
|
||||||
(lambda (_) (current-inexact-milliseconds))))
|
|
||||||
|
|
||||||
;; make-timer-heap : -> Heap
|
|
||||||
(define (make-timer-heap)
|
|
||||||
(make-heap (lambda (t1 t2) (<= (pending-timer-deadline t1) (pending-timer-deadline t2)))))
|
|
||||||
|
|
||||||
;; Retrieves the earliest-deadline timer from the heap, if there is
|
|
||||||
;; one.
|
|
||||||
;; next-timer! : Heap -> (Option pending-timer)
|
|
||||||
(define (next-timer! heap)
|
|
||||||
(if (zero? (heap-count heap))
|
|
||||||
#f
|
|
||||||
(heap-min heap)))
|
|
||||||
|
|
||||||
;; Retrieves (and removes) all timers from the heap that have deadline
|
|
||||||
;; earlier or equal to the time passed in.
|
|
||||||
;; fire-timers! : Heap Real -> (Listof SendMessage)
|
|
||||||
(define (fire-timers! heap now)
|
|
||||||
(if (zero? (heap-count heap))
|
|
||||||
'()
|
|
||||||
(let ((m (heap-min heap)))
|
|
||||||
(if (<= (pending-timer-deadline m) now)
|
|
||||||
(begin (heap-remove-min! heap)
|
|
||||||
(cons (send-message (timer-expired (pending-timer-label m) now))
|
|
||||||
(fire-timers! heap now)))
|
|
||||||
'()))))
|
|
||||||
|
|
||||||
;; Process for mapping this-level timer requests to ground-level timer
|
|
||||||
;; events and back.
|
|
||||||
;; timer-driver : (All (ParentState) -> (Spawn ParentState))
|
|
||||||
(define (timer-driver)
|
|
||||||
(name-process 'timer-driver
|
|
||||||
(spawn (transition (driver-state (make-timer-heap))
|
|
||||||
(subscriber (set-timer (wild) (wild) (wild))
|
|
||||||
(match-state state
|
|
||||||
(on-message
|
|
||||||
[(set-timer label msecs 'relative)
|
|
||||||
(install-timer! state label (+ (current-inexact-milliseconds) msecs))]
|
|
||||||
[(set-timer label msecs 'absolute)
|
|
||||||
(install-timer! state label msecs)])))
|
|
||||||
(publisher (timer-expired (wild) (wild)))))))
|
|
||||||
|
|
||||||
;; install-timer! : DriverState TimerLabel Real -> (Transition DriverState)
|
|
||||||
(define (install-timer! state label deadline)
|
|
||||||
(heap-add! (driver-state-heap state) (pending-timer deadline label))
|
|
||||||
(update-time-listener! state))
|
|
||||||
|
|
||||||
;; update-time-listener! : DriverState -> (Transition DriverState)
|
|
||||||
(define (update-time-listener! state)
|
|
||||||
(define next (next-timer! (driver-state-heap state)))
|
|
||||||
(transition state
|
|
||||||
(delete-endpoint 'time-listener)
|
|
||||||
(and next
|
|
||||||
(name-endpoint 'time-listener
|
|
||||||
(subscriber (cons (timer-evt (pending-timer-deadline next)) (wild))
|
|
||||||
(match-state state
|
|
||||||
(on-message
|
|
||||||
[(cons (? evt?) (? real? now))
|
|
||||||
(let ((to-send (fire-timers! (driver-state-heap state) now)))
|
|
||||||
;; Note: compute to-send before recursing, because of side-effects on heap
|
|
||||||
(sequence-actions (transition state)
|
|
||||||
update-time-listener!
|
|
||||||
to-send))])))))))
|
|
||||||
|
|
||||||
;; Process for mapping this-level timer requests to meta-level timer
|
|
||||||
;; requests. Useful when running nested VMs: essentially extends timer
|
|
||||||
;; support up the branches of the VM tree toward the leaves.
|
|
||||||
;; timer-relay : (All (ParentState) Symbol -> (Spawn ParentState))
|
|
||||||
(define (timer-relay self-id)
|
|
||||||
(name-process `(timer-relay ,self-id)
|
|
||||||
(spawn (transition (relay-state 0 (make-immutable-hash '()))
|
|
||||||
(at-meta-level
|
|
||||||
(subscriber (timer-expired (wild) (wild))
|
|
||||||
(match-state (relay-state next-counter active-timers)
|
|
||||||
(on-message
|
|
||||||
[(timer-expired (list (== self-id) (? exact-nonnegative-integer? counter))
|
|
||||||
now)
|
|
||||||
(transition (relay-state next-counter (hash-remove active-timers counter))
|
|
||||||
(and (hash-has-key? active-timers counter)
|
|
||||||
(send-message (timer-expired (hash-ref active-timers counter)
|
|
||||||
now))))]))))
|
|
||||||
(subscriber (set-timer (wild) (wild) (wild))
|
|
||||||
(match-state (relay-state next-counter active-timers)
|
|
||||||
(on-message
|
|
||||||
[(set-timer label msecs kind)
|
|
||||||
(transition (relay-state (+ next-counter 1)
|
|
||||||
(hash-set active-timers next-counter label))
|
|
||||||
(at-meta-level
|
|
||||||
(send-message (set-timer (list self-id next-counter) msecs kind))))])))
|
|
||||||
(publisher (timer-expired (wild) (wild)))))))
|
|
162
drivers/udp.rkt
162
drivers/udp.rkt
|
@ -1,162 +0,0 @@
|
||||||
#lang racket/base
|
|
||||||
;; UDP driver.
|
|
||||||
|
|
||||||
(require racket/set)
|
|
||||||
(require racket/match)
|
|
||||||
(require racket/udp)
|
|
||||||
|
|
||||||
(require "../sugar.rkt")
|
|
||||||
|
|
||||||
(provide (struct-out udp-remote-address)
|
|
||||||
(struct-out udp-handle)
|
|
||||||
(struct-out udp-listener)
|
|
||||||
|
|
||||||
udp-address?
|
|
||||||
udp-local-address?
|
|
||||||
|
|
||||||
(struct-out udp-packet)
|
|
||||||
udp-driver)
|
|
||||||
|
|
||||||
;; A UdpAddress is one of
|
|
||||||
;; -- a (udp-address String Uint16), representing a remote socket
|
|
||||||
;; -- a (udp-handle Any), representing a local socket on a kernel-assigned port
|
|
||||||
;; -- a (udp-listener Uint16), representing a local socket on a user-assigned port
|
|
||||||
;; Note that udp-handle-ids must be chosen carefully: they are scoped
|
|
||||||
;; to the local VM, i.e. shared between processes in that VM, so
|
|
||||||
;; processes must make sure not to accidentally clash in handle ID
|
|
||||||
;; selection.
|
|
||||||
(struct udp-remote-address (host port) #:transparent)
|
|
||||||
(struct udp-handle (id) #:transparent)
|
|
||||||
(struct udp-listener (port) #:transparent)
|
|
||||||
|
|
||||||
(define (udp-address? x)
|
|
||||||
(or (udp-remote-address? x)
|
|
||||||
(udp-handle? x)
|
|
||||||
(udp-listener? x)))
|
|
||||||
|
|
||||||
(define (udp-local-address? x)
|
|
||||||
(or (udp-handle? x)
|
|
||||||
(udp-listener? x)))
|
|
||||||
|
|
||||||
;; A UdpPacket is a (udp-packet UdpAddress UdpAddress Bytes), and
|
|
||||||
;; represents a packet appearing on our local "subnet" of the full UDP
|
|
||||||
;; network, complete with source, destination and contents.
|
|
||||||
(struct udp-packet (source destination body) #:transparent)
|
|
||||||
|
|
||||||
;; A HandleMapping is a record describing a mapping between a local
|
|
||||||
;; UdpAddress and its underlying UDP socket. It's private to the
|
|
||||||
;; implementation of the driver.
|
|
||||||
(struct handle-mapping (address socket) #:transparent)
|
|
||||||
|
|
||||||
;; TODO: BUG?: Routing packets between two local sockets won't work
|
|
||||||
;; because the patterns aren't set up to recognise that situation.
|
|
||||||
|
|
||||||
;; represents any remote address
|
|
||||||
;; any-remote : UdpAddressPattern
|
|
||||||
(define any-remote (udp-remote-address (wild) (wild)))
|
|
||||||
|
|
||||||
;; (define-type DriverState (Setof UdpLocalAddress))
|
|
||||||
|
|
||||||
;; (define-type SocketManagerState Boolean)
|
|
||||||
|
|
||||||
;; Process acting as a UDP socket factory.
|
|
||||||
;; udp-driver : (All (ParentState) -> (Spawn ParentState))
|
|
||||||
(define (udp-driver)
|
|
||||||
|
|
||||||
;; handle-presence : Topic DriverState -> (Transition DriverState)
|
|
||||||
(define (handle-presence topic active-handles)
|
|
||||||
(match-define (udp-packet _ (? udp-local-address? local-addr) _) topic)
|
|
||||||
(cond
|
|
||||||
[(set-member? active-handles local-addr)
|
|
||||||
(transition active-handles)]
|
|
||||||
[else
|
|
||||||
(transition (set-add active-handles local-addr)
|
|
||||||
(udp-socket-manager local-addr))]))
|
|
||||||
|
|
||||||
(name-process 'udp-driver
|
|
||||||
(spawn (transition (set)
|
|
||||||
|
|
||||||
(observe-subscribers (udp-packet any-remote (udp-handle (wild)) (wild))
|
|
||||||
(match-state active-handles
|
|
||||||
(match-conversation topic
|
|
||||||
(on-presence (handle-presence topic active-handles)))))
|
|
||||||
(observe-subscribers (udp-packet any-remote (udp-listener (wild)) (wild))
|
|
||||||
(match-state active-handles
|
|
||||||
(match-conversation topic
|
|
||||||
(on-presence (handle-presence topic active-handles)))))
|
|
||||||
(observe-publishers (udp-packet any-remote (udp-handle (wild)) (wild))
|
|
||||||
(match-state active-handles
|
|
||||||
(match-conversation topic
|
|
||||||
(on-presence (handle-presence topic active-handles)))))
|
|
||||||
(observe-publishers (udp-packet any-remote (udp-listener (wild)) (wild))
|
|
||||||
(match-state active-handles
|
|
||||||
(match-conversation topic
|
|
||||||
(on-presence (handle-presence topic active-handles)))))
|
|
||||||
|
|
||||||
(observe-publishers (handle-mapping (wild) (wild))
|
|
||||||
(match-state active-handles
|
|
||||||
(match-conversation (handle-mapping local-addr socket)
|
|
||||||
(on-absence
|
|
||||||
(transition (set-remove active-handles local-addr))))))
|
|
||||||
))))
|
|
||||||
|
|
||||||
;; bind-socket! : UDP-Socket UdpLocalAddress -> Void
|
|
||||||
(define (bind-socket! s local-addr)
|
|
||||||
(match local-addr
|
|
||||||
[(udp-listener port) (udp-bind! s #f port)]
|
|
||||||
[(udp-handle _) (udp-bind! s #f 0)]
|
|
||||||
[else (void)]))
|
|
||||||
|
|
||||||
;; valid-port-number? : Any -> Boolean : Natural
|
|
||||||
(define (valid-port-number? x)
|
|
||||||
;; Eventually TR will know about ranges
|
|
||||||
(exact-nonnegative-integer? x))
|
|
||||||
|
|
||||||
;; udp-socket-manager : UdpLocalAddress -> (Spawn DriverState)
|
|
||||||
(define (udp-socket-manager local-addr)
|
|
||||||
(define s (udp-open-socket #f #f))
|
|
||||||
(bind-socket! s local-addr)
|
|
||||||
(define buffer (make-bytes 65536)) ;; TODO: buffer size control
|
|
||||||
|
|
||||||
;; handle-absence : SocketManagerState -> (Transition SocketManagerState)
|
|
||||||
(define (handle-absence socket-is-open?)
|
|
||||||
(transition #f
|
|
||||||
(quit)
|
|
||||||
(when socket-is-open?
|
|
||||||
(name-process `(udp-socket-closer ,local-addr)
|
|
||||||
(spawn (begin (udp-close s)
|
|
||||||
(transition (void) (quit))))))))
|
|
||||||
|
|
||||||
(name-process `(udp-socket-manager ,local-addr)
|
|
||||||
(spawn (transition #t
|
|
||||||
;; Offers a handle-mapping on the local network so that
|
|
||||||
;; the driver/factory can clean up when this process dies.
|
|
||||||
(publisher (handle-mapping local-addr s))
|
|
||||||
;; If our counterparty removes either of their endpoints
|
|
||||||
;; as the subscriber end of the remote-to-local stream or
|
|
||||||
;; the publisher end of the local-to-remote stream, shut
|
|
||||||
;; ourselves down. Also, relay messages published on the
|
|
||||||
;; local-to-remote stream out on the actual socket.
|
|
||||||
(publisher (udp-packet any-remote local-addr (wild))
|
|
||||||
(match-state socket-is-open?
|
|
||||||
(on-absence (handle-absence socket-is-open?))))
|
|
||||||
(subscriber (udp-packet local-addr any-remote (wild))
|
|
||||||
(match-state socket-is-open?
|
|
||||||
(on-absence (handle-absence socket-is-open?))
|
|
||||||
(on-message
|
|
||||||
[(udp-packet (== local-addr)
|
|
||||||
(udp-remote-address remote-host remote-port)
|
|
||||||
body)
|
|
||||||
(begin (udp-send-to s remote-host remote-port body)
|
|
||||||
(transition socket-is-open?))])))
|
|
||||||
;; Listen for messages arriving on the actual socket using
|
|
||||||
;; a ground event, and relay them at this level.
|
|
||||||
(subscriber (cons (udp-receive!-evt s buffer) (wild))
|
|
||||||
(on-message
|
|
||||||
[(cons (? evt?) (list (? exact-integer? packet-length)
|
|
||||||
(? string? remote-host)
|
|
||||||
(? valid-port-number? remote-port)))
|
|
||||||
(let ((packet (subbytes buffer 0 packet-length)))
|
|
||||||
(send-message (udp-packet (udp-remote-address remote-host remote-port)
|
|
||||||
local-addr
|
|
||||||
packet)))]))))))
|
|
|
@ -1,46 +0,0 @@
|
||||||
#lang marketplace
|
|
||||||
|
|
||||||
(require racket/port)
|
|
||||||
|
|
||||||
;; Usually it's OK to just use display and friends directly.
|
|
||||||
;; Here we have a console output driver just to show how it's done.
|
|
||||||
(name-process 'console-output-driver
|
|
||||||
(spawn (transition/no-state
|
|
||||||
(subscriber (list 'console-output ?)
|
|
||||||
(on-message [(list 'console-output item)
|
|
||||||
(printf "~a" item)
|
|
||||||
(void)])))))
|
|
||||||
|
|
||||||
(name-process 'console-input-driver
|
|
||||||
(spawn (transition/no-state
|
|
||||||
(name-endpoint 'input-relay
|
|
||||||
(publisher (list 'console-input ?)
|
|
||||||
(on-absence
|
|
||||||
(send-message (list 'console-output "Connection terminated.\n"))
|
|
||||||
(quit))))
|
|
||||||
(subscriber (cons (read-line-evt (current-input-port) 'any) ?)
|
|
||||||
(on-message
|
|
||||||
[(cons _ (? eof-object?))
|
|
||||||
(send-message (list 'console-output "Terminating on local EOF.\n"))
|
|
||||||
(delete-endpoint 'input-relay)]
|
|
||||||
[(cons _ (? string? line))
|
|
||||||
(send-message (list 'console-input line))])))))
|
|
||||||
|
|
||||||
(name-process 'outbound-connection
|
|
||||||
(spawn (let ((local (tcp-handle 'outbound))
|
|
||||||
(remote (tcp-address "localhost" 5999)))
|
|
||||||
(transition/no-state
|
|
||||||
(subscriber (list 'console-input ?)
|
|
||||||
(on-absence (quit))
|
|
||||||
(on-message
|
|
||||||
[(list 'console-input line)
|
|
||||||
(send-message (list 'console-output (format "> ~a \n" line)))
|
|
||||||
(send-message (tcp-channel local remote (string-append line "\n")))]))
|
|
||||||
(publisher (tcp-channel local remote ?))
|
|
||||||
(subscriber (tcp-channel remote local ?)
|
|
||||||
(on-absence (quit))
|
|
||||||
(on-message
|
|
||||||
[(tcp-channel _ _ (? eof-object?))
|
|
||||||
(quit)]
|
|
||||||
[(tcp-channel _ _ data)
|
|
||||||
(send-message (list 'console-output (format "< ~a" data)))]))))))
|
|
|
@ -1,88 +0,0 @@
|
||||||
#lang marketplace
|
|
||||||
;; Equivalent to chat-paper.rkt, but using the raw unsugared
|
|
||||||
;; structures rather than the friendly DSL overlay.
|
|
||||||
|
|
||||||
(require racket/match)
|
|
||||||
(require marketplace)
|
|
||||||
|
|
||||||
(make-nested-vm
|
|
||||||
(lambda (vm-pid)
|
|
||||||
(process-spec (lambda (boot-pid)
|
|
||||||
(lambda (k)
|
|
||||||
(k (transition stateless
|
|
||||||
(at-meta-level
|
|
||||||
(add-endpoint 'listener
|
|
||||||
(role 'subscriber
|
|
||||||
(tcp-channel ? (tcp-listener 5999) ?)
|
|
||||||
'observer)
|
|
||||||
listener-event-handler))))))))
|
|
||||||
#f)
|
|
||||||
|
|
||||||
(define listener-event-handler
|
|
||||||
(match-lambda
|
|
||||||
[(presence-event (role _ (tcp-channel them us _) _))
|
|
||||||
(lambda (state)
|
|
||||||
(transition state
|
|
||||||
(spawn (process-spec (lambda (pid) (lambda (k) (k (chat-session them us)))))
|
|
||||||
#f
|
|
||||||
#f)))]
|
|
||||||
[_
|
|
||||||
(lambda (state) (transition state '()))]))
|
|
||||||
|
|
||||||
(define (chat-session them us)
|
|
||||||
(define user (gensym 'user))
|
|
||||||
(transition stateless
|
|
||||||
(list (listen-to-user user them us)
|
|
||||||
(speak-to-user user them us))))
|
|
||||||
|
|
||||||
(define (listen-to-user user them us)
|
|
||||||
(list
|
|
||||||
(at-meta-level
|
|
||||||
(add-endpoint 'tcp-receiver
|
|
||||||
(role 'subscriber
|
|
||||||
(tcp-channel them us ?)
|
|
||||||
'participant)
|
|
||||||
(match-lambda
|
|
||||||
[(absence-event _ _)
|
|
||||||
(lambda (state)
|
|
||||||
(transition state (quit #f #f)))]
|
|
||||||
[(message-event _ (tcp-channel _ _ (? bytes? text)))
|
|
||||||
(lambda (state)
|
|
||||||
(transition state (send-message `(,user says ,text) 'publisher)))]
|
|
||||||
[_
|
|
||||||
(lambda (state) (transition state '()))])))
|
|
||||||
(add-endpoint 'speech-publisher
|
|
||||||
(role 'publisher
|
|
||||||
`(,user says ,?)
|
|
||||||
'participant)
|
|
||||||
(lambda (event)
|
|
||||||
(lambda (state) (transition state '()))))))
|
|
||||||
|
|
||||||
(define (speak-to-user user them us)
|
|
||||||
(define (say fmt . args)
|
|
||||||
(at-meta-level
|
|
||||||
(send-message (tcp-channel us them (apply format fmt args))
|
|
||||||
'publisher)))
|
|
||||||
(define (announce who did-what)
|
|
||||||
(unless (equal? who user)
|
|
||||||
(say "~s ~s.~n" who did-what)))
|
|
||||||
(list
|
|
||||||
(say "You are ~s.~n" user)
|
|
||||||
(at-meta-level
|
|
||||||
(add-endpoint 'tcp-sender
|
|
||||||
(role 'publisher
|
|
||||||
(tcp-channel us them ?)
|
|
||||||
'participant)
|
|
||||||
(lambda (event)
|
|
||||||
(lambda (state) (transition state '())))))
|
|
||||||
(add-endpoint 'speech-subscriber
|
|
||||||
(role 'subscriber
|
|
||||||
`(,? says ,?)
|
|
||||||
'participant)
|
|
||||||
(match-lambda
|
|
||||||
[(presence-event (role _ `(,who says ,_) _))
|
|
||||||
(lambda (state) (transition state (announce who 'arrived)))]
|
|
||||||
[(absence-event (role _ `(,who says ,_) _) _)
|
|
||||||
(lambda (state) (transition state (announce who 'departed)))]
|
|
||||||
[(message-event _ `(,who says ,what))
|
|
||||||
(lambda (state) (transition state (say "~a: ~a" who what)))]))))
|
|
|
@ -1,46 +0,0 @@
|
||||||
#lang marketplace
|
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
(spawn-vm
|
|
||||||
(at-meta-level
|
|
||||||
(observe-publishers (tcp-channel ? (tcp-listener 5999) ?)
|
|
||||||
(match-conversation (tcp-channel them us _)
|
|
||||||
(on-presence (spawn (chat-session them us)))))))
|
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
(define (chat-session them us)
|
|
||||||
(define user (gensym 'user))
|
|
||||||
(transition stateless
|
|
||||||
(listen-to-user user them us)
|
|
||||||
(speak-to-user user them us)))
|
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
(define (listen-to-user user them us)
|
|
||||||
(list
|
|
||||||
(at-meta-level
|
|
||||||
(subscriber (tcp-channel them us ?)
|
|
||||||
(on-absence (quit))
|
|
||||||
(on-message
|
|
||||||
[(tcp-channel _ _ (? bytes? text))
|
|
||||||
(send-message `(,user says ,text))])))
|
|
||||||
(publisher `(,user says ,?))))
|
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
(define (speak-to-user user them us)
|
|
||||||
(define (say fmt . args)
|
|
||||||
(at-meta-level
|
|
||||||
(send-message
|
|
||||||
(tcp-channel us them (apply format fmt args)))))
|
|
||||||
(define (announce who did-what)
|
|
||||||
(unless (equal? who user)
|
|
||||||
(say "~s ~s.~n" who did-what)))
|
|
||||||
(list
|
|
||||||
(say "You are ~s.~n" user)
|
|
||||||
(at-meta-level
|
|
||||||
(publisher (tcp-channel us them ?)))
|
|
||||||
(subscriber `(,? says ,?)
|
|
||||||
(match-conversation `(,who says ,_)
|
|
||||||
(on-presence (announce who 'arrived))
|
|
||||||
(on-absence (announce who 'departed))
|
|
||||||
(on-message [`(,who says ,what)
|
|
||||||
(say "~a: ~a" who what)])))))
|
|
|
@ -1,57 +0,0 @@
|
||||||
-module(chat).
|
|
||||||
|
|
||||||
-export([start/0]).
|
|
||||||
|
|
||||||
start() ->
|
|
||||||
IndexPid = spawn(fun () -> index([]) end),
|
|
||||||
{ok, LSock} = gen_tcp:listen(5999, [{active, true}, {packet, line}, {reuseaddr, true}]),
|
|
||||||
accept_loop(LSock, IndexPid).
|
|
||||||
|
|
||||||
accept_loop(LSock, IndexPid) ->
|
|
||||||
case gen_tcp:accept(LSock) of
|
|
||||||
{ok, Sock} ->
|
|
||||||
gen_tcp:controlling_process(Sock, spawn(fun () -> connection(Sock, IndexPid) end)),
|
|
||||||
accept_loop(LSock, IndexPid)
|
|
||||||
end.
|
|
||||||
|
|
||||||
index(Connected) ->
|
|
||||||
receive
|
|
||||||
{arrive, Pid} ->
|
|
||||||
[begin
|
|
||||||
P ! {utterance, {arrive, Pid}},
|
|
||||||
Pid ! {utterance, {arrive, P}}
|
|
||||||
end || P <- Connected],
|
|
||||||
monitor(process, Pid),
|
|
||||||
index([Pid | Connected]);
|
|
||||||
{'DOWN', _, process, Pid, _} ->
|
|
||||||
NewConnected = Connected -- [Pid],
|
|
||||||
[P ! {utterance, {depart, Pid}} || P <- NewConnected],
|
|
||||||
index(NewConnected);
|
|
||||||
M = {_Pid, says, _Thing} ->
|
|
||||||
[P ! {utterance, M} || P <- Connected],
|
|
||||||
index(Connected);
|
|
||||||
Other ->
|
|
||||||
error_logger:error_report({index, unhandled, Other})
|
|
||||||
end.
|
|
||||||
|
|
||||||
say(Sock, V) ->
|
|
||||||
gen_tcp:send(Sock, io_lib:format("~p~n", [V])).
|
|
||||||
|
|
||||||
connection(Sock, IndexPid) ->
|
|
||||||
IndexPid ! {arrive, self()},
|
|
||||||
say(Sock, {you_are, self()}),
|
|
||||||
connection_mainloop(Sock, IndexPid).
|
|
||||||
|
|
||||||
connection_mainloop(Sock, IndexPid) ->
|
|
||||||
receive
|
|
||||||
{utterance, V} ->
|
|
||||||
say(Sock, V),
|
|
||||||
connection_mainloop(Sock, IndexPid);
|
|
||||||
{tcp, _, Line} ->
|
|
||||||
IndexPid ! {self(), says, Line},
|
|
||||||
connection_mainloop(Sock, IndexPid);
|
|
||||||
{tcp_closed, _} ->
|
|
||||||
ok;
|
|
||||||
Other ->
|
|
||||||
error_logger:error_report({connection, unhandled, Other})
|
|
||||||
end.
|
|
|
@ -1,54 +0,0 @@
|
||||||
import Network.Socket
|
|
||||||
import Data.List
|
|
||||||
import System.IO
|
|
||||||
import Control.Exception
|
|
||||||
import Control.Concurrent
|
|
||||||
import Control.Concurrent.STM
|
|
||||||
import Control.Monad
|
|
||||||
|
|
||||||
hGetLineStripped hdl = liftM (filter (not . flip elem "\n\r")) (hGetLine hdl)
|
|
||||||
|
|
||||||
main = do
|
|
||||||
index <- newTVarIO []
|
|
||||||
sock <- socket AF_INET Stream 0
|
|
||||||
setSocketOption sock ReuseAddr 1
|
|
||||||
bindSocket sock (SockAddrInet 5999 iNADDR_ANY)
|
|
||||||
listen sock 2
|
|
||||||
mainLoop index sock 0
|
|
||||||
|
|
||||||
mainLoop index sock n = do
|
|
||||||
conn <- accept sock
|
|
||||||
forkIO (runConn index conn ("user" ++ show n))
|
|
||||||
mainLoop index sock $! n+1
|
|
||||||
|
|
||||||
runConn index (sock, _) name = do
|
|
||||||
hdl <- socketToHandle sock ReadWriteMode
|
|
||||||
hSetBuffering hdl NoBuffering
|
|
||||||
handle (\(SomeException _) -> return ()) $ (do arrive index name hdl
|
|
||||||
connLoop index name hdl)
|
|
||||||
depart index name hdl
|
|
||||||
hClose hdl
|
|
||||||
|
|
||||||
broadcast str conns = sequence_ $ map sendStr conns
|
|
||||||
where sendStr (_, hdl) = hPutStrLn hdl str
|
|
||||||
|
|
||||||
arrive index name hdl = do
|
|
||||||
hPutStrLn hdl ("you are " ++ name)
|
|
||||||
old <- atomically $ do old <- readTVar index
|
|
||||||
writeTVar index ((name, hdl) : old)
|
|
||||||
return old
|
|
||||||
broadcast (name ++ " arrived") old
|
|
||||||
sequence_ $ map (\ (otherName, _) -> hPutStrLn hdl (otherName ++ " arrived")) old
|
|
||||||
|
|
||||||
depart index name hdl = do
|
|
||||||
new <- atomically $ do old <- readTVar index
|
|
||||||
let new = old \\ [(name, hdl)]
|
|
||||||
writeTVar index new
|
|
||||||
return new
|
|
||||||
broadcast (name ++ " departed") new
|
|
||||||
|
|
||||||
connLoop index name hdl = do
|
|
||||||
line <- hGetLineStripped hdl
|
|
||||||
curr <- atomically $ readTVar index
|
|
||||||
broadcast (name ++ " says " ++ line) curr
|
|
||||||
connLoop index name hdl
|
|
|
@ -1,50 +0,0 @@
|
||||||
from __future__ import with_statement
|
|
||||||
from SocketServer import ThreadingMixIn, TCPServer, StreamRequestHandler
|
|
||||||
from threading import RLock
|
|
||||||
|
|
||||||
active_connections = set()
|
|
||||||
active_connection_mutex = RLock()
|
|
||||||
|
|
||||||
class ChatServer(ThreadingMixIn, TCPServer):
|
|
||||||
allow_reuse_address = True
|
|
||||||
|
|
||||||
counter = 0
|
|
||||||
|
|
||||||
class ConnectionHandler(StreamRequestHandler):
|
|
||||||
def handle(self):
|
|
||||||
global counter
|
|
||||||
self.connection_id = 'user' + str(counter)
|
|
||||||
counter = counter + 1
|
|
||||||
try:
|
|
||||||
self.arrive()
|
|
||||||
while True:
|
|
||||||
line = self.rfile.readline()
|
|
||||||
if not line: break
|
|
||||||
for c in active_connections.copy():
|
|
||||||
c.announce('%s says %s' % (self.connection_id, line.strip()))
|
|
||||||
finally:
|
|
||||||
self.depart()
|
|
||||||
|
|
||||||
def arrive(self):
|
|
||||||
self.announce('you are %s' % (self.connection_id,))
|
|
||||||
with active_connection_mutex:
|
|
||||||
for c in active_connections:
|
|
||||||
self.announce('%s arrived' % (c.connection_id,))
|
|
||||||
c.announce('%s arrived' % (self.connection_id,))
|
|
||||||
active_connections.add(self)
|
|
||||||
|
|
||||||
def depart(self):
|
|
||||||
with active_connection_mutex:
|
|
||||||
active_connections.discard(self)
|
|
||||||
for c in active_connections:
|
|
||||||
c.announce('%s departed' % (self.connection_id,))
|
|
||||||
|
|
||||||
def announce(self, s):
|
|
||||||
try:
|
|
||||||
self.wfile.write(s + '\n')
|
|
||||||
except IOError:
|
|
||||||
self.depart()
|
|
||||||
|
|
||||||
if __name__ == '__main__':
|
|
||||||
s = ChatServer(('localhost', 5999), ConnectionHandler)
|
|
||||||
s.serve_forever()
|
|
|
@ -1,47 +0,0 @@
|
||||||
#lang marketplace
|
|
||||||
|
|
||||||
(require "../support/debug.rkt")
|
|
||||||
|
|
||||||
(debug
|
|
||||||
(spawn-vm
|
|
||||||
(at-meta-level
|
|
||||||
(observe-publishers (tcp-channel ? (tcp-listener 5999) ?)
|
|
||||||
(match-conversation (tcp-channel them us _)
|
|
||||||
(on-presence
|
|
||||||
(debug (name-process (list 'session them)
|
|
||||||
(spawn (chat-session them us))))))))))
|
|
||||||
|
|
||||||
(define (chat-session them us)
|
|
||||||
(define user (gensym 'user))
|
|
||||||
(transition stateless
|
|
||||||
(listen-to-user user them us)
|
|
||||||
(speak-to-user user them us)))
|
|
||||||
|
|
||||||
(define (listen-to-user user them us)
|
|
||||||
(list
|
|
||||||
(publisher `(,user says ,?))
|
|
||||||
(at-meta-level
|
|
||||||
(subscriber (tcp-channel them us ?)
|
|
||||||
(on-absence (quit))
|
|
||||||
(on-message
|
|
||||||
[(tcp-channel _ _ (? bytes? text))
|
|
||||||
(send-message `(,user says ,text))])))))
|
|
||||||
|
|
||||||
(define (speak-to-user user them us)
|
|
||||||
(define (say fmt . args)
|
|
||||||
(at-meta-level
|
|
||||||
(send-message
|
|
||||||
(tcp-channel us them (apply format fmt args)))))
|
|
||||||
(define (announce who did-what)
|
|
||||||
(unless (equal? who user)
|
|
||||||
(say "~s ~s.~n" who did-what)))
|
|
||||||
(list
|
|
||||||
(say "You are ~s.~n" user)
|
|
||||||
(at-meta-level
|
|
||||||
(publisher (tcp-channel us them ?)))
|
|
||||||
(subscriber `(,? says ,?)
|
|
||||||
(match-conversation `(,who says ,_)
|
|
||||||
(on-presence (announce who 'arrived))
|
|
||||||
(on-absence (announce who 'departed))
|
|
||||||
(on-message [`(,who says ,what)
|
|
||||||
(say "~a: ~a" who what)])))))
|
|
|
@ -1,14 +0,0 @@
|
||||||
#lang marketplace
|
|
||||||
|
|
||||||
(observe-publishers (tcp-channel ? (tcp-listener 5999) ?)
|
|
||||||
(match-conversation (tcp-channel from to _)
|
|
||||||
(on-presence (spawn (echoer from to)))))
|
|
||||||
|
|
||||||
(define (echoer from to)
|
|
||||||
(transition stateless
|
|
||||||
(publisher (tcp-channel to from ?))
|
|
||||||
(subscriber (tcp-channel from to ?)
|
|
||||||
(on-absence (quit))
|
|
||||||
(on-message
|
|
||||||
[(tcp-channel _ _ data)
|
|
||||||
(send-message (tcp-channel to from data))]))))
|
|
|
@ -1,19 +0,0 @@
|
||||||
#lang racket/base
|
|
||||||
;; Plain Racket version, using (require) instead of #lang marketplace.
|
|
||||||
|
|
||||||
(require marketplace/sugar)
|
|
||||||
(require marketplace/drivers/tcp-bare)
|
|
||||||
|
|
||||||
(define (echoer from to)
|
|
||||||
(transition/no-state
|
|
||||||
(publisher (tcp-channel to from ?))
|
|
||||||
(subscriber (tcp-channel from to ?)
|
|
||||||
(on-absence (quit))
|
|
||||||
(on-message
|
|
||||||
[(tcp-channel _ _ data)
|
|
||||||
(send-message (tcp-channel to from data))]))))
|
|
||||||
|
|
||||||
(ground-vm tcp
|
|
||||||
(observe-publishers (tcp-channel ? (tcp-listener 5999) ?)
|
|
||||||
(match-conversation (tcp-channel from to _)
|
|
||||||
(on-presence (spawn (echoer from to))))))
|
|
|
@ -0,0 +1,27 @@
|
||||||
|
|
||||||
|
.NoteBox {
|
||||||
|
position: relative;
|
||||||
|
float: right;
|
||||||
|
left: 2em;
|
||||||
|
height: 0em;
|
||||||
|
width: 13em;
|
||||||
|
margin: 0em -13em 0em 0em;
|
||||||
|
}
|
||||||
|
|
||||||
|
.NoteContent {
|
||||||
|
margin: 0 0 0 0;
|
||||||
|
font-size: 85%;
|
||||||
|
}
|
||||||
|
|
||||||
|
.FootnoteContent {
|
||||||
|
display: none;
|
||||||
|
}
|
||||||
|
|
||||||
|
.FootnoteBlock {
|
||||||
|
border-top: 1px solid black;
|
||||||
|
}
|
||||||
|
|
||||||
|
.FootnoteBlockContent {
|
||||||
|
padding-left: 1em;
|
||||||
|
text-indent: -0.5em;
|
||||||
|
}
|
68
ground.rkt
68
ground.rkt
|
@ -1,68 +0,0 @@
|
||||||
#lang racket/base
|
|
||||||
|
|
||||||
(require racket/match)
|
|
||||||
(require "structs.rkt")
|
|
||||||
(require "roles.rkt")
|
|
||||||
(require "vm.rkt")
|
|
||||||
(require "log.rkt")
|
|
||||||
(require "process.rkt")
|
|
||||||
(require "actions.rkt")
|
|
||||||
(require "action-send-message.rkt")
|
|
||||||
(require "quasiqueue.rkt")
|
|
||||||
|
|
||||||
(provide run-ground-vm)
|
|
||||||
|
|
||||||
;; run-ground-vm : process-spec -> Void
|
|
||||||
(define (run-ground-vm boot)
|
|
||||||
(let loop ((state (make-vm boot)))
|
|
||||||
(match (run-vm state)
|
|
||||||
[(transition state actions)
|
|
||||||
(define is-blocking?
|
|
||||||
(match (quasiqueue->list (action-tree->quasiqueue actions))
|
|
||||||
['()
|
|
||||||
;; no "yield" action -> certainly blocking
|
|
||||||
#t]
|
|
||||||
[(list (yield (== run-vm)))
|
|
||||||
;; single "yield", with k statically known to be run-vm -> poll
|
|
||||||
#f]
|
|
||||||
[_
|
|
||||||
;; uh-oh
|
|
||||||
(error 'ground-vm
|
|
||||||
"Cannot process meta-actions ~v because no further metalevel exists"
|
|
||||||
actions)]))
|
|
||||||
(define active-events
|
|
||||||
(endpoint-fold extract-ground-event-subscriptions '() state))
|
|
||||||
(if (and is-blocking?
|
|
||||||
(null? active-events))
|
|
||||||
(begin
|
|
||||||
;; Not polling, and no events that could wake us from blocking, so quit
|
|
||||||
(marketplace-log 'debug "Ground VM returning normally.")
|
|
||||||
(sleep 0.2) ;; give the log-receivers a chance to drain (!)
|
|
||||||
(void))
|
|
||||||
(let ((interruptk (apply sync
|
|
||||||
(if is-blocking?
|
|
||||||
never-evt
|
|
||||||
(wrap-evt always-evt (lambda (dummy) values)))
|
|
||||||
active-events)))
|
|
||||||
(loop (interruptk state))))])))
|
|
||||||
|
|
||||||
;; extract-ground-event-subscriptions :
|
|
||||||
;; (All (State) (process State) (endpoint State) (Listof Evt) -> (Listof Evt))
|
|
||||||
(define (extract-ground-event-subscriptions old-p ep acc)
|
|
||||||
(define pid (process-pid old-p))
|
|
||||||
(match (endpoint-role ep)
|
|
||||||
[(role 'subscriber (cons (? evt? evt) _) 'participant)
|
|
||||||
;; evt-handler : Any -> (vm -> vm)
|
|
||||||
(define ((evt-handler message) state)
|
|
||||||
(let-values (((state wp) (extract-process state pid)))
|
|
||||||
(if (not wp)
|
|
||||||
state
|
|
||||||
(let ((p wp))
|
|
||||||
(let-values
|
|
||||||
(((p state)
|
|
||||||
(do-send-message 'publisher (cons evt message) p state)))
|
|
||||||
(if p
|
|
||||||
(inject-process state p)
|
|
||||||
state))))))
|
|
||||||
(cons (wrap-evt evt evt-handler) acc)]
|
|
||||||
[_ acc]))
|
|
File diff suppressed because one or more lines are too long
File diff suppressed because one or more lines are too long
10
info.rkt
10
info.rkt
|
@ -1,10 +0,0 @@
|
||||||
#lang setup/infotab
|
|
||||||
(define scribblings '(("scribblings/marketplace.scrbl" (multi-page))))
|
|
||||||
(define deps '("base"
|
|
||||||
"data-lib"
|
|
||||||
"gui-lib"
|
|
||||||
"images-lib"
|
|
||||||
"rackunit-lib"))
|
|
||||||
(define build-deps '("scribble-lib"
|
|
||||||
"slideshow-lib"
|
|
||||||
"typed-racket-lib"))
|
|
|
@ -1,68 +0,0 @@
|
||||||
#lang racket/base
|
|
||||||
|
|
||||||
(require (for-syntax racket/base))
|
|
||||||
(require (for-syntax racket/pretty))
|
|
||||||
|
|
||||||
(require "../sugar.rkt")
|
|
||||||
(require "../drivers/tcp-bare.rkt")
|
|
||||||
(require "../support/spy.rkt")
|
|
||||||
|
|
||||||
(provide (rename-out [module-begin #%module-begin])
|
|
||||||
(except-out (all-from-out racket/base) #%module-begin)
|
|
||||||
(all-from-out "../sugar.rkt")
|
|
||||||
(all-from-out "../drivers/tcp-bare.rkt")
|
|
||||||
(all-from-out "../support/spy.rkt")
|
|
||||||
stateless)
|
|
||||||
|
|
||||||
(define stateless (void))
|
|
||||||
|
|
||||||
(define-syntax (module-begin stx)
|
|
||||||
(unless (eq? (syntax-local-context) 'module-begin)
|
|
||||||
(raise-syntax-error #f "allowed only around a module body" stx))
|
|
||||||
(syntax-case stx ()
|
|
||||||
[(_ forms ...)
|
|
||||||
(let ()
|
|
||||||
(define (accumulate-actions action-ids final-forms forms)
|
|
||||||
(if (null? forms)
|
|
||||||
(let ((final-stx
|
|
||||||
#`(#%module-begin #,@(reverse final-forms)
|
|
||||||
(ground-vm tcp #,@(reverse action-ids)))))
|
|
||||||
;;(pretty-print (syntax->datum final-stx))
|
|
||||||
final-stx)
|
|
||||||
(syntax-case (local-expand (car forms)
|
|
||||||
'module
|
|
||||||
(syntax->list #'(quote
|
|
||||||
quote-syntax #%top
|
|
||||||
lambda case-lambda
|
|
||||||
let-values letrec-values
|
|
||||||
begin begin0 set!
|
|
||||||
with-continuation-mark
|
|
||||||
if #%app #%expression
|
|
||||||
define-values define-syntaxes
|
|
||||||
begin-for-syntax
|
|
||||||
module module*
|
|
||||||
#%module-begin
|
|
||||||
#%require #%provide
|
|
||||||
#%variable-reference))) ()
|
|
||||||
[(head rest ...)
|
|
||||||
(if (free-identifier=? #'head #'begin)
|
|
||||||
(accumulate-actions action-ids
|
|
||||||
final-forms
|
|
||||||
(append (syntax->list #'(rest ...)) (cdr forms)))
|
|
||||||
(if (ormap (lambda (i) (free-identifier=? #'head i))
|
|
||||||
(syntax->list #'(define-values define-syntaxes begin-for-syntax
|
|
||||||
module module*
|
|
||||||
#%module-begin
|
|
||||||
#%require #%provide)))
|
|
||||||
(accumulate-actions action-ids
|
|
||||||
(cons (car forms) final-forms)
|
|
||||||
(cdr forms))
|
|
||||||
(accumulate-action (car forms) action-ids final-forms (cdr forms))))]
|
|
||||||
[non-pair-syntax
|
|
||||||
(accumulate-action (car forms) action-ids final-forms (cdr forms))])))
|
|
||||||
(define (accumulate-action action action-ids final-forms remaining-forms)
|
|
||||||
(define temp (car (generate-temporaries (list action))))
|
|
||||||
(accumulate-actions (cons temp action-ids)
|
|
||||||
(cons #`(define #,temp #,action) final-forms)
|
|
||||||
remaining-forms))
|
|
||||||
(accumulate-actions '() '() (syntax->list #'(forms ...))))]))
|
|
|
@ -1,2 +0,0 @@
|
||||||
#lang s-exp syntax/module-reader
|
|
||||||
marketplace/lang/base
|
|
|
@ -1,7 +0,0 @@
|
||||||
#lang racket/base
|
|
||||||
|
|
||||||
(provide list-max)
|
|
||||||
|
|
||||||
;; list-max : (Listof Integer) -> Integer
|
|
||||||
(define (list-max xs)
|
|
||||||
(foldr max 0 xs))
|
|
38
log.rkt
38
log.rkt
|
@ -1,38 +0,0 @@
|
||||||
#lang racket/base
|
|
||||||
|
|
||||||
(require racket/match)
|
|
||||||
|
|
||||||
(provide marketplace-root-logger
|
|
||||||
marketplace-log)
|
|
||||||
|
|
||||||
(define marketplace-root-logger (make-logger 'marketplace #f))
|
|
||||||
|
|
||||||
(define-syntax marketplace-log
|
|
||||||
(syntax-rules ()
|
|
||||||
[(_ level-exp message)
|
|
||||||
(let ((level level-exp))
|
|
||||||
(when (log-level? marketplace-root-logger level)
|
|
||||||
(log-message marketplace-root-logger level message #f)))]
|
|
||||||
[(_ level format-string exp ...)
|
|
||||||
(marketplace-log level (format format-string exp ...))]))
|
|
||||||
|
|
||||||
(define (level-code level)
|
|
||||||
(match level
|
|
||||||
['debug "D"]
|
|
||||||
['info "I"]
|
|
||||||
['warning "W"]
|
|
||||||
['error "E"]
|
|
||||||
['fatal "F"]
|
|
||||||
[other (symbol->string other)]))
|
|
||||||
|
|
||||||
(match (getenv "MARKETPLACE_LOG")
|
|
||||||
[#f (void)]
|
|
||||||
[str (let ((level (string->symbol str)))
|
|
||||||
(define receiver (make-log-receiver marketplace-root-logger level))
|
|
||||||
(thread
|
|
||||||
(lambda ()
|
|
||||||
(let loop ()
|
|
||||||
(match (sync receiver)
|
|
||||||
[(vector level message data event-name)
|
|
||||||
(fprintf (current-error-port) "~a/~a\n" (level-code level) message)])
|
|
||||||
(loop)))))])
|
|
File diff suppressed because one or more lines are too long
27
main.rkt
27
main.rkt
|
@ -1,27 +0,0 @@
|
||||||
#lang racket/base
|
|
||||||
;; Virtualized operating system, this time with presence.
|
|
||||||
|
|
||||||
;; TODO: contracts for State checking
|
|
||||||
;; TODO: revisit exposure of PIDs to processes.
|
|
||||||
;; - make processes parametric in the PID type?
|
|
||||||
;; - simply make PIDs unavailable to processes?
|
|
||||||
;; - revisit points-of-attachment idea, and expose presence on PIDs properly?
|
|
||||||
|
|
||||||
(require racket/match)
|
|
||||||
(require "structs.rkt")
|
|
||||||
(require "roles.rkt")
|
|
||||||
(require "vm.rkt")
|
|
||||||
(require "actions.rkt")
|
|
||||||
(require "nested.rkt")
|
|
||||||
(require "ground.rkt")
|
|
||||||
(require "unify.rkt")
|
|
||||||
|
|
||||||
(provide (all-from-out "structs.rkt")
|
|
||||||
(all-from-out "roles.rkt")
|
|
||||||
make-nested-vm
|
|
||||||
run-ground-vm
|
|
||||||
|
|
||||||
wild
|
|
||||||
wild?
|
|
||||||
non-wild?
|
|
||||||
ground?)
|
|
File diff suppressed because one or more lines are too long
|
@ -0,0 +1,307 @@
|
||||||
|
/* See the beginning of "manual.css". */
|
||||||
|
|
||||||
|
/* Monospace: */
|
||||||
|
|
||||||
|
.RktIn, .RktRdr, .RktPn, .RktMeta,
|
||||||
|
.RktMod, .RktKw, .RktVar, .RktSym,
|
||||||
|
.RktRes, .RktOut, .RktCmt, .RktVal,
|
||||||
|
.RktBlk, .RktErr {
|
||||||
|
font-family: 'Source Code Pro', monospace;
|
||||||
|
white-space: inherit;
|
||||||
|
font-size: 1rem;
|
||||||
|
}
|
||||||
|
|
||||||
|
/* this selctor grabs the first linked Racket symbol
|
||||||
|
in a definition box (i.e., the symbol being defined) */
|
||||||
|
a.RktValDef, a.RktStxDef, a.RktSymDef,
|
||||||
|
span.RktValDef, span.RktStxDef, span.RktSymDef
|
||||||
|
{
|
||||||
|
font-size: 1.15rem;
|
||||||
|
color: black;
|
||||||
|
font-weight: 600;
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
.inheritedlbl {
|
||||||
|
font-family: 'Fira', sans;
|
||||||
|
}
|
||||||
|
|
||||||
|
.RBackgroundLabelInner {
|
||||||
|
font-family: inherit;
|
||||||
|
}
|
||||||
|
|
||||||
|
/* ---------------------------------------- */
|
||||||
|
/* Inherited methods, left margin */
|
||||||
|
|
||||||
|
.inherited {
|
||||||
|
width: 95%;
|
||||||
|
margin-top: 0.5em;
|
||||||
|
text-align: left;
|
||||||
|
background-color: inherit;
|
||||||
|
}
|
||||||
|
|
||||||
|
.inherited td {
|
||||||
|
font-size: 82%;
|
||||||
|
padding-left: 0.5rem;
|
||||||
|
line-height: 1.3em;
|
||||||
|
text-indent: 0;
|
||||||
|
padding-right: 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
.inheritedlbl {
|
||||||
|
font-style: normal;
|
||||||
|
}
|
||||||
|
|
||||||
|
/* ---------------------------------------- */
|
||||||
|
/* Racket text styles */
|
||||||
|
|
||||||
|
.RktIn {
|
||||||
|
color: #cc6633;
|
||||||
|
background-color: #eee;
|
||||||
|
}
|
||||||
|
|
||||||
|
.RktInBG {
|
||||||
|
background-color: #eee;
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
.refcolumn .RktInBG {
|
||||||
|
background-color: white;
|
||||||
|
}
|
||||||
|
|
||||||
|
.RktRdr {
|
||||||
|
}
|
||||||
|
|
||||||
|
.RktPn {
|
||||||
|
color: #843c24;
|
||||||
|
}
|
||||||
|
|
||||||
|
.RktMeta {
|
||||||
|
color: black;
|
||||||
|
}
|
||||||
|
|
||||||
|
.RktMod {
|
||||||
|
color: inherit;
|
||||||
|
}
|
||||||
|
|
||||||
|
.RktOpt {
|
||||||
|
color: black;
|
||||||
|
}
|
||||||
|
|
||||||
|
.RktKw {
|
||||||
|
color: black;
|
||||||
|
}
|
||||||
|
|
||||||
|
.RktErr {
|
||||||
|
color: red;
|
||||||
|
font-style: italic;
|
||||||
|
font-weight: 400;
|
||||||
|
}
|
||||||
|
|
||||||
|
.RktVar {
|
||||||
|
position: relative;
|
||||||
|
left: -1px; font-style: italic;
|
||||||
|
color: #444;
|
||||||
|
}
|
||||||
|
|
||||||
|
.SVInsetFlow .RktVar {
|
||||||
|
font-weight: 400;
|
||||||
|
color: #444;
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
.RktSym {
|
||||||
|
color: inherit;
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
.RktValLink, .RktStxLink, .RktModLink {
|
||||||
|
text-decoration: none;
|
||||||
|
color: #07A;
|
||||||
|
font-weight: 500;
|
||||||
|
font-size: 1rem;
|
||||||
|
}
|
||||||
|
|
||||||
|
/* for syntax links within headings */
|
||||||
|
h2 a.RktStxLink, h3 a.RktStxLink, h4 a.RktStxLink, h5 a.RktStxLink,
|
||||||
|
h2 a.RktValLink, h3 a.RktValLink, h4 a.RktValLink, h5 a.RktValLink,
|
||||||
|
h2 .RktSym, h3 .RktSym, h4 .RktSym, h5 .RktSym,
|
||||||
|
h2 .RktMod, h3 .RktMod, h4 .RktMod, h5 .RktMod,
|
||||||
|
h2 .RktVal, h3 .RktVal, h4 .RktVal, h5 .RktVal,
|
||||||
|
h2 .RktPn, h3 .RktPn, h4 .RktPn, h5 .RktPn {
|
||||||
|
color: #333;
|
||||||
|
font-size: 1.65rem;
|
||||||
|
font-weight: 400;
|
||||||
|
}
|
||||||
|
|
||||||
|
.toptoclink .RktStxLink, .toclink .RktStxLink,
|
||||||
|
.toptoclink .RktValLink, .toclink .RktValLink,
|
||||||
|
.toptoclink .RktModLink, .toclink .RktModLink {
|
||||||
|
color: inherit;
|
||||||
|
}
|
||||||
|
|
||||||
|
.tocset .RktValLink, .tocset .RktStxLink, .tocset .RktModLink {
|
||||||
|
color: black;
|
||||||
|
font-weight: 400;
|
||||||
|
font-size: 0.9rem;
|
||||||
|
}
|
||||||
|
|
||||||
|
.tocset td a.tocviewselflink .RktValLink,
|
||||||
|
.tocset td a.tocviewselflink .RktStxLink,
|
||||||
|
.tocset td a.tocviewselflink .RktMod,
|
||||||
|
.tocset td a.tocviewselflink .RktSym {
|
||||||
|
font-weight: lighter;
|
||||||
|
color: white;
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
.RktRes {
|
||||||
|
color: #0000af;
|
||||||
|
}
|
||||||
|
|
||||||
|
.RktOut {
|
||||||
|
color: #960096;
|
||||||
|
}
|
||||||
|
|
||||||
|
.RktCmt {
|
||||||
|
color: #c2741f;
|
||||||
|
}
|
||||||
|
|
||||||
|
.RktVal {
|
||||||
|
color: #228b22;
|
||||||
|
}
|
||||||
|
|
||||||
|
/* ---------------------------------------- */
|
||||||
|
/* Some inline styles */
|
||||||
|
|
||||||
|
.together { /* for definitions grouped together in one box */
|
||||||
|
width: 100%;
|
||||||
|
border-top: 2px solid white;
|
||||||
|
}
|
||||||
|
|
||||||
|
tbody > tr:first-child > td > .together {
|
||||||
|
border-top: 0px; /* erase border on first instance of together */
|
||||||
|
}
|
||||||
|
|
||||||
|
.RktBlk {
|
||||||
|
white-space: normal;
|
||||||
|
text-align: left;
|
||||||
|
}
|
||||||
|
|
||||||
|
.highlighted {
|
||||||
|
font-size: 1rem;
|
||||||
|
background-color: #fee;
|
||||||
|
}
|
||||||
|
|
||||||
|
.defmodule {
|
||||||
|
font-family: 'Source Code Pro';
|
||||||
|
padding: 0.25rem 0.75rem 0.25rem 0.5rem;
|
||||||
|
margin-bottom: 1rem;
|
||||||
|
width: 100%;
|
||||||
|
background-color: hsl(60, 29%, 94%);
|
||||||
|
}
|
||||||
|
|
||||||
|
.defmodule a {
|
||||||
|
color: #444;
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
.defmodule td span.hspace:first-child {
|
||||||
|
position: absolute;
|
||||||
|
width: 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
.defmodule .RpackageSpec .Smaller,
|
||||||
|
.defmodule .RpackageSpec .stt {
|
||||||
|
font-size: 1rem;
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
.specgrammar {
|
||||||
|
float: none;
|
||||||
|
padding-left: 1em;
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
.RBibliography td {
|
||||||
|
vertical-align: text-top;
|
||||||
|
padding-top: 1em;
|
||||||
|
}
|
||||||
|
|
||||||
|
.leftindent {
|
||||||
|
margin-left: 2rem;
|
||||||
|
margin-right: 0em;
|
||||||
|
}
|
||||||
|
|
||||||
|
.insetpara {
|
||||||
|
margin-left: 1em;
|
||||||
|
margin-right: 1em;
|
||||||
|
}
|
||||||
|
|
||||||
|
.SCodeFlow .Rfilebox {
|
||||||
|
margin-left: -1em; /* see 17.2 of guide, module languages */
|
||||||
|
}
|
||||||
|
|
||||||
|
.Rfiletitle {
|
||||||
|
text-align: right;
|
||||||
|
background-color: #eee;
|
||||||
|
}
|
||||||
|
|
||||||
|
.SCodeFlow .Rfiletitle {
|
||||||
|
border-top: 1px dotted gray;
|
||||||
|
border-right: 1px dotted gray;
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
.Rfilename {
|
||||||
|
border-top: 0;
|
||||||
|
border-right: 0;
|
||||||
|
padding-left: 0.5em;
|
||||||
|
padding-right: 0.5em;
|
||||||
|
background-color: inherit;
|
||||||
|
}
|
||||||
|
|
||||||
|
.Rfilecontent {
|
||||||
|
margin: 0.5em;
|
||||||
|
}
|
||||||
|
|
||||||
|
.RpackageSpec {
|
||||||
|
padding-right: 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
/* ---------------------------------------- */
|
||||||
|
/* For background labels */
|
||||||
|
|
||||||
|
.RBackgroundLabel {
|
||||||
|
float: right;
|
||||||
|
width: 0px;
|
||||||
|
height: 0px;
|
||||||
|
}
|
||||||
|
|
||||||
|
.RBackgroundLabelInner {
|
||||||
|
position: relative;
|
||||||
|
width: 25em;
|
||||||
|
left: -25.5em;
|
||||||
|
top: 0.20rem; /* sensitive to monospaced font choice */
|
||||||
|
text-align: right;
|
||||||
|
z-index: 0;
|
||||||
|
font-weight: 300;
|
||||||
|
font-family: 'Source Code Pro';
|
||||||
|
font-size: 0.9rem;
|
||||||
|
color: gray;
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
.RpackageSpec .Smaller {
|
||||||
|
font-weight: 300;
|
||||||
|
font-family: 'Source Code Pro';
|
||||||
|
font-size: 0.9rem;
|
||||||
|
}
|
||||||
|
|
||||||
|
.RForeground {
|
||||||
|
position: relative;
|
||||||
|
left: 0px;
|
||||||
|
top: 0px;
|
||||||
|
z-index: 1;
|
||||||
|
}
|
|
@ -0,0 +1,728 @@
|
||||||
|
|
||||||
|
/* See the beginning of "scribble.css".
|
||||||
|
This file is used by the `scribble/manual` language, along with
|
||||||
|
"manual-racket.css". */
|
||||||
|
|
||||||
|
@import url("manual-fonts.css");
|
||||||
|
|
||||||
|
* {
|
||||||
|
margin: 0;
|
||||||
|
padding: 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
@media all {html {font-size: 15px;}}
|
||||||
|
@media all and (max-width:940px){html {font-size: 14px;}}
|
||||||
|
@media all and (max-width:850px){html {font-size: 13px;}}
|
||||||
|
@media all and (max-width:830px){html {font-size: 12px;}}
|
||||||
|
@media all and (max-width:740px){html {font-size: 11px;}}
|
||||||
|
|
||||||
|
/* CSS seems backward: List all the classes for which we want a
|
||||||
|
particular font, so that the font can be changed in one place. (It
|
||||||
|
would be nicer to reference a font definition from all the places
|
||||||
|
that we want it.)
|
||||||
|
|
||||||
|
As you read the rest of the file, remember to double-check here to
|
||||||
|
see if any font is set. */
|
||||||
|
|
||||||
|
/* Monospace: */
|
||||||
|
.maincolumn, .refpara, .refelem, .tocset, .stt, .hspace, .refparaleft, .refelemleft {
|
||||||
|
font-family: 'Source Code Pro', monospace;
|
||||||
|
white-space: inherit;
|
||||||
|
font-size: 1rem;
|
||||||
|
}
|
||||||
|
|
||||||
|
.stt {
|
||||||
|
font-weight: 500;
|
||||||
|
}
|
||||||
|
|
||||||
|
h2 .stt {
|
||||||
|
font-size: 2.7rem;
|
||||||
|
}
|
||||||
|
|
||||||
|
.toptoclink .stt {
|
||||||
|
font-size: inherit;
|
||||||
|
}
|
||||||
|
.toclink .stt {
|
||||||
|
font-size: 90%;
|
||||||
|
}
|
||||||
|
|
||||||
|
.RpackageSpec .stt {
|
||||||
|
font-weight: 300;
|
||||||
|
font-family: 'Source Code Pro';
|
||||||
|
font-size: 0.9rem;
|
||||||
|
}
|
||||||
|
|
||||||
|
h3 .stt, h4 .stt, h5 .stt {
|
||||||
|
color: #333;
|
||||||
|
font-size: 1.65rem;
|
||||||
|
font-weight: 400;
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
/* Serif: */
|
||||||
|
.main, .refcontent, .tocview, .tocsub, .sroman, i {
|
||||||
|
font-family: 'Charter', serif;
|
||||||
|
font-size: 1.18rem;
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
/* Sans-serif: */
|
||||||
|
.version, .versionNoNav, .ssansserif {
|
||||||
|
font-family: 'Fira', sans-serif;
|
||||||
|
}
|
||||||
|
.ssansserif {
|
||||||
|
font-family: 'Fira';
|
||||||
|
font-weight: 500;
|
||||||
|
font-size: 0.9em;
|
||||||
|
}
|
||||||
|
|
||||||
|
.tocset .ssansserif {
|
||||||
|
font-size: 100%;
|
||||||
|
}
|
||||||
|
|
||||||
|
/* ---------------------------------------- */
|
||||||
|
|
||||||
|
p, .SIntrapara {
|
||||||
|
display: block;
|
||||||
|
margin: 0 0 1em 0;
|
||||||
|
line-height: 140%;
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
li {
|
||||||
|
list-style-position: outside;
|
||||||
|
margin-left: 1.2em;
|
||||||
|
}
|
||||||
|
|
||||||
|
h1, h2, h3, h4, h5, h6, h7, h8 {
|
||||||
|
font-family: 'Fira';
|
||||||
|
font-weight: 300;
|
||||||
|
font-size: 1.6rem;
|
||||||
|
color: #333;
|
||||||
|
margin-top: inherit;
|
||||||
|
margin-bottom: 1rem;
|
||||||
|
line-height: 125%;
|
||||||
|
-moz-font-feature-settings: 'tnum=1';
|
||||||
|
-moz-font-feature-settings: 'tnum' 1;
|
||||||
|
-webkit-font-feature-settings: 'tnum' 1;
|
||||||
|
-o-font-feature-settings: 'tnum' 1;
|
||||||
|
-ms-font-feature-settings: 'tnum' 1;
|
||||||
|
font-feature-settings: 'tnum' 1;
|
||||||
|
|
||||||
|
}
|
||||||
|
|
||||||
|
h3, h4, h5, h6, h7, h8 {
|
||||||
|
border-top: 1px solid black;
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
h2 { /* per-page main title */
|
||||||
|
font-family: 'Miso';
|
||||||
|
font-weight: bold;
|
||||||
|
margin-top: 4rem;
|
||||||
|
font-size: 3rem;
|
||||||
|
line-height: 110%;
|
||||||
|
width: 90%;
|
||||||
|
}
|
||||||
|
|
||||||
|
h3, h4, h5, h6, h7, h8 {
|
||||||
|
margin-top: 2em;
|
||||||
|
padding-top: 0.1em;
|
||||||
|
margin-bottom: 0.75em;
|
||||||
|
}
|
||||||
|
|
||||||
|
/* ---------------------------------------- */
|
||||||
|
/* Main */
|
||||||
|
|
||||||
|
body {
|
||||||
|
color: black;
|
||||||
|
background-color: white;
|
||||||
|
}
|
||||||
|
|
||||||
|
.maincolumn {
|
||||||
|
width: auto;
|
||||||
|
margin-top: 4rem;
|
||||||
|
margin-left: 17rem;
|
||||||
|
margin-right: 2rem;
|
||||||
|
margin-bottom: 10rem; /* to avoid fixed bottom nav bar */
|
||||||
|
max-width: 700px;
|
||||||
|
min-width: 370px; /* below this size, code samples don't fit */
|
||||||
|
}
|
||||||
|
|
||||||
|
a {
|
||||||
|
text-decoration: inherit;
|
||||||
|
}
|
||||||
|
|
||||||
|
a, .toclink, .toptoclink, .tocviewlink, .tocviewselflink, .tocviewtoggle, .plainlink,
|
||||||
|
.techinside, .techoutside:hover, .techinside:hover {
|
||||||
|
color: #07A;
|
||||||
|
}
|
||||||
|
|
||||||
|
a:hover {
|
||||||
|
text-decoration: underline;
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
/* ---------------------------------------- */
|
||||||
|
/* Navigation */
|
||||||
|
|
||||||
|
.navsettop, .navsetbottom {
|
||||||
|
left: 0;
|
||||||
|
width: 15rem;
|
||||||
|
height: 6rem;
|
||||||
|
font-family: 'Fira';
|
||||||
|
font-size: 0.9rem;
|
||||||
|
border-bottom: 0px solid hsl(216, 15%, 70%);
|
||||||
|
background-color: inherit;
|
||||||
|
padding: 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
.navsettop {
|
||||||
|
position: absolute;
|
||||||
|
top: 0;
|
||||||
|
left: 0;
|
||||||
|
margin-bottom: 0;
|
||||||
|
border-bottom: 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
.navsettop a, .navsetbottom a {
|
||||||
|
color: black;
|
||||||
|
}
|
||||||
|
|
||||||
|
.navsettop a:hover, .navsetbottom a:hover {
|
||||||
|
background: hsl(216, 78%, 95%);
|
||||||
|
text-decoration: none;
|
||||||
|
}
|
||||||
|
|
||||||
|
.navleft, .navright {
|
||||||
|
position: static;
|
||||||
|
float: none;
|
||||||
|
margin: 0;
|
||||||
|
white-space: normal;
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
.navleft a {
|
||||||
|
display: inline-block;
|
||||||
|
}
|
||||||
|
|
||||||
|
.navright a {
|
||||||
|
display: inline-block;
|
||||||
|
text-align: center;
|
||||||
|
}
|
||||||
|
|
||||||
|
.navleft a, .navright a, .navright span {
|
||||||
|
display: inline-block;
|
||||||
|
padding: 0.5rem;
|
||||||
|
min-width: 1rem;
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
.navright {
|
||||||
|
height: 2rem;
|
||||||
|
white-space: nowrap;
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
.navsetbottom {
|
||||||
|
display: none;
|
||||||
|
}
|
||||||
|
|
||||||
|
.nonavigation {
|
||||||
|
color: #889;
|
||||||
|
}
|
||||||
|
|
||||||
|
.searchform {
|
||||||
|
display: block;
|
||||||
|
margin: 0;
|
||||||
|
padding: 0;
|
||||||
|
border-bottom: 1px solid #eee;
|
||||||
|
height: 4rem;
|
||||||
|
}
|
||||||
|
|
||||||
|
.searchbox {
|
||||||
|
font-size: 1rem;
|
||||||
|
width: 12rem;
|
||||||
|
margin: 1rem;
|
||||||
|
padding: 0.25rem;
|
||||||
|
vertical-align: middle;
|
||||||
|
background-color: white;
|
||||||
|
}
|
||||||
|
|
||||||
|
#search_box {
|
||||||
|
font-size: 0.8rem;
|
||||||
|
}
|
||||||
|
|
||||||
|
/* ---------------------------------------- */
|
||||||
|
/* Version */
|
||||||
|
|
||||||
|
.versionbox {
|
||||||
|
position: absolute;
|
||||||
|
float: none;
|
||||||
|
top: 0.25rem;
|
||||||
|
left: 17rem;
|
||||||
|
z-index: 11000;
|
||||||
|
height: 2em;
|
||||||
|
font-size: 70%;
|
||||||
|
font-weight: lighter;
|
||||||
|
width: inherit;
|
||||||
|
margin: 0;
|
||||||
|
}
|
||||||
|
.version, .versionNoNav {
|
||||||
|
font-size: inherit;
|
||||||
|
}
|
||||||
|
.version:before, .versionNoNav:before {
|
||||||
|
content: "v.";
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
/* ---------------------------------------- */
|
||||||
|
/* Margin notes */
|
||||||
|
|
||||||
|
/* cancel scribvle.css styles: */
|
||||||
|
.refpara, .refelem {
|
||||||
|
position: static;
|
||||||
|
float: none;
|
||||||
|
height: auto;
|
||||||
|
width: auto;
|
||||||
|
margin: 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
.refcolumn {
|
||||||
|
position: static;
|
||||||
|
display: block;
|
||||||
|
width: auto;
|
||||||
|
font-size: inherit;
|
||||||
|
margin: 2rem;
|
||||||
|
margin-left: 2rem;
|
||||||
|
padding: 0.5em;
|
||||||
|
padding-left: 0.75em;
|
||||||
|
padding-right: 1em;
|
||||||
|
background: hsl(60, 29%, 94%);
|
||||||
|
border: 1px solid #ccb;
|
||||||
|
border-left: 0.4rem solid #ccb;
|
||||||
|
}
|
||||||
|
|
||||||
|
.refcontent p {
|
||||||
|
line-height: 1.5rem;
|
||||||
|
margin: 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
.refcontent p + p {
|
||||||
|
margin-top: 1em;
|
||||||
|
}
|
||||||
|
|
||||||
|
.refcontent a {
|
||||||
|
font-weight: 400;
|
||||||
|
}
|
||||||
|
|
||||||
|
.refcontent img {
|
||||||
|
width: 1.5em;
|
||||||
|
}
|
||||||
|
|
||||||
|
.refpara, .refparaleft {
|
||||||
|
top: -1em;
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
@media all and (max-width:600px) {
|
||||||
|
.refcolumn {
|
||||||
|
margin-left: 0;
|
||||||
|
margin-right: 0;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
@media all and (min-width:1260px) {
|
||||||
|
.refcolumn {
|
||||||
|
position: absolute;
|
||||||
|
left: 66rem; right: 3em;
|
||||||
|
margin: 0;
|
||||||
|
float: right;
|
||||||
|
max-width: 18rem;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
.refcontent {
|
||||||
|
font-family: 'Fira';
|
||||||
|
font-size: 1rem;
|
||||||
|
line-height: 160%;
|
||||||
|
margin: 0 0 0 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
.refparaleft, .refelemleft {
|
||||||
|
position: relative;
|
||||||
|
float: left;
|
||||||
|
right: 2em;
|
||||||
|
height: 0em;
|
||||||
|
width: 13em;
|
||||||
|
margin: 0em 0em 0em -13em;
|
||||||
|
}
|
||||||
|
|
||||||
|
.refcolumnleft {
|
||||||
|
background-color: hsl(60, 29%, 94%);
|
||||||
|
display: block;
|
||||||
|
position: relative;
|
||||||
|
width: 13em;
|
||||||
|
font-size: 85%;
|
||||||
|
border: 0.5em solid hsl(60, 29%, 94%);
|
||||||
|
margin: 0 0 0 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
/* ---------------------------------------- */
|
||||||
|
/* Table of contents, left margin */
|
||||||
|
|
||||||
|
.tocset {
|
||||||
|
position: absolute;
|
||||||
|
float: none;
|
||||||
|
left: 0;
|
||||||
|
top: 0rem;
|
||||||
|
width: 14rem;
|
||||||
|
padding: 7rem 0.5rem 0.5rem 0.5rem;
|
||||||
|
background-color: hsl(216, 15%, 70%);
|
||||||
|
margin: 0;
|
||||||
|
|
||||||
|
}
|
||||||
|
|
||||||
|
.tocset td {
|
||||||
|
vertical-align: text-top;
|
||||||
|
padding-bottom: 0.4rem;
|
||||||
|
padding-left: 0.2rem;
|
||||||
|
line-height: 110%;
|
||||||
|
font-family: 'Fira';
|
||||||
|
-moz-font-feature-settings: 'tnum=1';
|
||||||
|
-moz-font-feature-settings: 'tnum' 1;
|
||||||
|
-webkit-font-feature-settings: 'tnum' 1;
|
||||||
|
-o-font-feature-settings: 'tnum' 1;
|
||||||
|
-ms-font-feature-settings: 'tnum' 1;
|
||||||
|
font-feature-settings: 'tnum' 1;
|
||||||
|
|
||||||
|
}
|
||||||
|
|
||||||
|
.tocset td a {
|
||||||
|
color: black;
|
||||||
|
font-weight: 400;
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
.tocview {
|
||||||
|
text-align: left;
|
||||||
|
background-color: inherit;
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
.tocview td, .tocsub td {
|
||||||
|
line-height: 1.3em;
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
.tocview table, .tocsub table {
|
||||||
|
width: 90%;
|
||||||
|
}
|
||||||
|
|
||||||
|
.tocset td a.tocviewselflink {
|
||||||
|
font-weight: lighter;
|
||||||
|
font-size: 110%; /* monospaced styles below don't need to enlarge */
|
||||||
|
color: white;
|
||||||
|
}
|
||||||
|
|
||||||
|
.tocviewselflink {
|
||||||
|
text-decoration: none;
|
||||||
|
}
|
||||||
|
|
||||||
|
.tocsub {
|
||||||
|
text-align: left;
|
||||||
|
margin-top: 0.5em;
|
||||||
|
background-color: inherit;
|
||||||
|
}
|
||||||
|
|
||||||
|
.tocviewlist, .tocsublist {
|
||||||
|
margin-left: 0.2em;
|
||||||
|
margin-right: 0.2em;
|
||||||
|
padding-top: 0.2em;
|
||||||
|
padding-bottom: 0.2em;
|
||||||
|
}
|
||||||
|
.tocviewlist table {
|
||||||
|
font-size: 82%;
|
||||||
|
}
|
||||||
|
|
||||||
|
.tocviewlisttopspace {
|
||||||
|
margin-bottom: 1em;
|
||||||
|
}
|
||||||
|
|
||||||
|
.tocviewsublist, .tocviewsublistonly, .tocviewsublisttop, .tocviewsublistbottom {
|
||||||
|
margin-left: 0.4em;
|
||||||
|
border-left: 1px solid #99a;
|
||||||
|
padding-left: 0.8em;
|
||||||
|
}
|
||||||
|
.tocviewsublist {
|
||||||
|
margin-bottom: 1em;
|
||||||
|
}
|
||||||
|
.tocviewsublist table,
|
||||||
|
.tocviewsublistonly table,
|
||||||
|
.tocviewsublisttop table,
|
||||||
|
.tocviewsublistbottom table,
|
||||||
|
table.tocsublist {
|
||||||
|
font-size: 1rem;
|
||||||
|
}
|
||||||
|
|
||||||
|
.tocviewsublist td, .tocviewsublistbottom td, .tocviewsublisttop td, .tocsub td,
|
||||||
|
.tocviewsublistonly td {
|
||||||
|
font-size: 90%;
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
.tocviewtoggle {
|
||||||
|
font-size: 75%; /* looks better, and avoids bounce when toggling sub-sections due to font alignments */
|
||||||
|
}
|
||||||
|
|
||||||
|
.tocsublist td {
|
||||||
|
padding-left: 0.5rem;
|
||||||
|
padding-top: 0.25rem;
|
||||||
|
text-indent: 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
.tocsublinknumber {
|
||||||
|
font-size: 100%;
|
||||||
|
}
|
||||||
|
|
||||||
|
.tocsublink {
|
||||||
|
font-size: 82%;
|
||||||
|
text-decoration: none;
|
||||||
|
}
|
||||||
|
|
||||||
|
.tocsubseclink {
|
||||||
|
font-size: 100%;
|
||||||
|
text-decoration: none;
|
||||||
|
}
|
||||||
|
|
||||||
|
.tocsubnonseclink {
|
||||||
|
font-size: 82%;
|
||||||
|
text-decoration: none;
|
||||||
|
margin-left: 1rem;
|
||||||
|
padding-left: 0;
|
||||||
|
display: inline-block;
|
||||||
|
}
|
||||||
|
|
||||||
|
/* the label "on this page" */
|
||||||
|
.tocsubtitle {
|
||||||
|
display: block;
|
||||||
|
font-size: 62%;
|
||||||
|
font-family: 'Fira';
|
||||||
|
font-weight: bolder;
|
||||||
|
font-style: normal;
|
||||||
|
letter-spacing: 2px;
|
||||||
|
text-transform: uppercase;
|
||||||
|
margin: 0.5em;
|
||||||
|
}
|
||||||
|
|
||||||
|
.toptoclink {
|
||||||
|
font-weight: bold;
|
||||||
|
font-size: 110%
|
||||||
|
}
|
||||||
|
|
||||||
|
/* hack to add space around .toptoclink because markup is all td */
|
||||||
|
.toptoclink:after {
|
||||||
|
content: " ";
|
||||||
|
font-size: 3rem;
|
||||||
|
}
|
||||||
|
|
||||||
|
.toclink {
|
||||||
|
font-size: inherit;
|
||||||
|
}
|
||||||
|
|
||||||
|
/* ---------------------------------------- */
|
||||||
|
/* Some inline styles */
|
||||||
|
|
||||||
|
.indexlink {
|
||||||
|
text-decoration: none;
|
||||||
|
}
|
||||||
|
|
||||||
|
pre {
|
||||||
|
margin-left: 2em;
|
||||||
|
}
|
||||||
|
|
||||||
|
blockquote {
|
||||||
|
margin-left: 2em;
|
||||||
|
margin-right: 2em;
|
||||||
|
margin-bottom: 1em;
|
||||||
|
}
|
||||||
|
|
||||||
|
.SCodeFlow {
|
||||||
|
border-left: 1px dotted black;
|
||||||
|
padding-left: 1em;
|
||||||
|
padding-right: 1em;
|
||||||
|
margin-top: 1em;
|
||||||
|
margin-bottom: 1em;
|
||||||
|
margin-left: 0em;
|
||||||
|
margin-right: 2em;
|
||||||
|
white-space: nowrap;
|
||||||
|
line-height: 1.4em;
|
||||||
|
}
|
||||||
|
|
||||||
|
.SCodeFlow img {
|
||||||
|
margin-top: 0.5em;
|
||||||
|
margin-bottom: 0.5em;
|
||||||
|
}
|
||||||
|
|
||||||
|
.SVInsetFlow, .SIntrapara > table.RBoxed {
|
||||||
|
margin: 0;
|
||||||
|
margin-top: 2em;
|
||||||
|
padding: 0.25em;
|
||||||
|
padding-bottom: 0.5em;
|
||||||
|
background: #f3f3f3;
|
||||||
|
box-sizing:border-box;
|
||||||
|
border-top: 1px solid #99b;
|
||||||
|
background: hsl(216, 78%, 95%);
|
||||||
|
background: -moz-linear-gradient(to bottom left, hsl(0, 0%, 99%) 0%, hsl(216, 78%, 95%) 100%);
|
||||||
|
background: -webkit-linear-gradient(to bottom left, hsl(0, 0%, 99%) 0%, hsl(216, 78%, 95%) 100%);
|
||||||
|
background: -o-linear-gradient(to bottom left, hsl(0, 0%, 99%) 0%, hsl(216, 78%, 95%) 100%);
|
||||||
|
background: -ms-linear-gradient(to bottom left, hsl(0, 0%, 99%) 0%, hsl(216, 78%, 95%) 100%);
|
||||||
|
background: linear-gradient(to bottom left, hsl(0, 0%, 99%) 0%, hsl(216, 78%, 95%) 100%);
|
||||||
|
}
|
||||||
|
|
||||||
|
blockquote > blockquote.SVInsetFlow {
|
||||||
|
/* resolves issue in e.g. /reference/notation.html */
|
||||||
|
margin-top: 0em;
|
||||||
|
}
|
||||||
|
|
||||||
|
.leftindent .SVInsetFlow { /* see e.g. section 4.5 of Racket Guide */
|
||||||
|
margin-top: 1em;
|
||||||
|
margin-bottom: 1em;
|
||||||
|
}
|
||||||
|
|
||||||
|
.SVInsetFlow a, .SCodeFlow a {
|
||||||
|
color: #07A;
|
||||||
|
font-weight: 500;
|
||||||
|
}
|
||||||
|
|
||||||
|
.SubFlow {
|
||||||
|
display: block;
|
||||||
|
margin: 0em;
|
||||||
|
}
|
||||||
|
|
||||||
|
.boxed {
|
||||||
|
width: 100%;
|
||||||
|
background-color: inherit;
|
||||||
|
}
|
||||||
|
|
||||||
|
.techoutside { text-decoration: none; }
|
||||||
|
|
||||||
|
.SAuthorListBox {
|
||||||
|
position: static;
|
||||||
|
float: none;
|
||||||
|
font-family: 'Fira';
|
||||||
|
font-weight: 300;
|
||||||
|
font-size: 110%;
|
||||||
|
margin-top: 1rem;
|
||||||
|
margin-bottom: 3rem;
|
||||||
|
width: auto;
|
||||||
|
height: auto;
|
||||||
|
}
|
||||||
|
|
||||||
|
.author > a { /* email links within author block */
|
||||||
|
font-weight: inherit;
|
||||||
|
color: inherit;
|
||||||
|
}
|
||||||
|
|
||||||
|
.SAuthorList {
|
||||||
|
font-size: 82%;
|
||||||
|
}
|
||||||
|
.SAuthorList:before {
|
||||||
|
content: "by ";
|
||||||
|
}
|
||||||
|
.author {
|
||||||
|
display: inline;
|
||||||
|
white-space: nowrap;
|
||||||
|
}
|
||||||
|
|
||||||
|
/* phone + tablet styles */
|
||||||
|
|
||||||
|
@media all and (max-width:720px){
|
||||||
|
|
||||||
|
|
||||||
|
@media all and (max-width:720px){
|
||||||
|
|
||||||
|
@media all {html {font-size: 15px;}}
|
||||||
|
@media all and (max-width:700px){html {font-size: 14px;}}
|
||||||
|
@media all and (max-width:630px){html {font-size: 13px;}}
|
||||||
|
@media all and (max-width:610px){html {font-size: 12px;}}
|
||||||
|
@media all and (max-width:550px){html {font-size: 11px;}}
|
||||||
|
@media all and (max-width:520px){html {font-size: 10px;}}
|
||||||
|
|
||||||
|
.navsettop, .navsetbottom {
|
||||||
|
display: block;
|
||||||
|
position: absolute;
|
||||||
|
width: 100%;
|
||||||
|
height: 4rem;
|
||||||
|
border: 0;
|
||||||
|
background-color: hsl(216, 15%, 70%);
|
||||||
|
}
|
||||||
|
|
||||||
|
.searchform {
|
||||||
|
display: inline;
|
||||||
|
border: 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
.navright {
|
||||||
|
position: absolute;
|
||||||
|
right: 1.5rem;
|
||||||
|
margin-top: 1rem;
|
||||||
|
border: 0px solid red;
|
||||||
|
}
|
||||||
|
|
||||||
|
.navsetbottom {
|
||||||
|
display: block;
|
||||||
|
margin-top: 8rem;
|
||||||
|
}
|
||||||
|
|
||||||
|
.tocset {
|
||||||
|
display: none;
|
||||||
|
}
|
||||||
|
|
||||||
|
.tocset table, .tocset tbody, .tocset tr, .tocset td {
|
||||||
|
display: inline;
|
||||||
|
}
|
||||||
|
|
||||||
|
.tocview {
|
||||||
|
display: none;
|
||||||
|
}
|
||||||
|
|
||||||
|
.tocsub .tocsubtitle {
|
||||||
|
display: none;
|
||||||
|
}
|
||||||
|
|
||||||
|
.versionbox {
|
||||||
|
top: 4.5rem;
|
||||||
|
left: 1rem; /* same distance as main-column */
|
||||||
|
z-index: 11000;
|
||||||
|
height: 2em;
|
||||||
|
font-size: 70%;
|
||||||
|
font-weight: lighter;
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
.maincolumn {
|
||||||
|
margin-left: 1em;
|
||||||
|
margin-top: 7rem;
|
||||||
|
margin-bottom: 0rem;
|
||||||
|
}
|
||||||
|
|
||||||
|
}
|
||||||
|
|
||||||
|
}
|
||||||
|
|
||||||
|
/* print styles : hide the navigation elements */
|
||||||
|
@media print {
|
||||||
|
.tocset,
|
||||||
|
.navsettop,
|
||||||
|
.navsetbottom { display: none; }
|
||||||
|
.maincolumn {
|
||||||
|
width: auto;
|
||||||
|
margin-right: 13em;
|
||||||
|
margin-left: 0;
|
||||||
|
}
|
||||||
|
}
|
18
nested.rkt
18
nested.rkt
|
@ -1,18 +0,0 @@
|
||||||
#lang racket/base
|
|
||||||
|
|
||||||
(require racket/match)
|
|
||||||
(require "structs.rkt")
|
|
||||||
(require "roles.rkt")
|
|
||||||
(require "vm.rkt")
|
|
||||||
(require "actions.rkt")
|
|
||||||
|
|
||||||
(provide make-nested-vm)
|
|
||||||
|
|
||||||
;; make-nested-vm : (All (State) (PID -> process-spec) Any -> (spawn State))
|
|
||||||
(define (make-nested-vm make-boot debug-name)
|
|
||||||
(spawn (process-spec (lambda (nested-vm-pid)
|
|
||||||
(lambda (k) (k (run-vm (make-vm (make-boot nested-vm-pid)))))))
|
|
||||||
#f
|
|
||||||
debug-name))
|
|
||||||
|
|
||||||
;; TODO: (process-spec: NewProcessState (pid-id) transition-expr)
|
|
Binary file not shown.
After Width: | Height: | Size: 14 KiB |
Binary file not shown.
After Width: | Height: | Size: 14 KiB |
141
process.rkt
141
process.rkt
|
@ -1,141 +0,0 @@
|
||||||
#lang racket/base
|
|
||||||
|
|
||||||
(require racket/match)
|
|
||||||
(require "structs.rkt")
|
|
||||||
(require "roles.rkt")
|
|
||||||
(require "vm.rkt")
|
|
||||||
(require "log.rkt")
|
|
||||||
(require "quasiqueue.rkt")
|
|
||||||
|
|
||||||
(provide send-to-user
|
|
||||||
send-to-user*
|
|
||||||
action-tree->quasiqueue
|
|
||||||
quit-interruptk
|
|
||||||
run-ready
|
|
||||||
notify-route-change-vm)
|
|
||||||
|
|
||||||
(define-syntax-rule (send-to-user p (e) failure-result enclosed-expr)
|
|
||||||
(send-to-user* (process-debug-name p) (process-pid p) (e) failure-result enclosed-expr))
|
|
||||||
|
|
||||||
(define-syntax-rule (send-to-user* debug-name pid (e) failure-result enclosed-expr)
|
|
||||||
(with-handlers ([exn:fail? (lambda (e)
|
|
||||||
(if (exn? e)
|
|
||||||
(marketplace-log 'error "Process ~v(~v):~n~a~n"
|
|
||||||
debug-name pid (exn-message e))
|
|
||||||
(marketplace-log 'error "Process ~v(~v):~n~v~n"
|
|
||||||
debug-name pid e))
|
|
||||||
failure-result)])
|
|
||||||
(marketplace-log 'debug "Entering process ~v(~v)" debug-name pid)
|
|
||||||
(define result enclosed-expr)
|
|
||||||
(marketplace-log 'debug "Leaving process ~v(~v)" debug-name pid)
|
|
||||||
result))
|
|
||||||
|
|
||||||
;; action-tree->quasiqueue : (All (State) (ActionTree State) -> (QuasiQueue (Action State)))
|
|
||||||
;; TODO: simplify
|
|
||||||
(define (action-tree->quasiqueue t)
|
|
||||||
(let loop ((revacc '()) (t t))
|
|
||||||
(cond
|
|
||||||
[(pair? t) (loop (loop revacc (car t)) (cdr t))]
|
|
||||||
[(or (null? t) (eq? t #f) (void? t)) revacc]
|
|
||||||
[else (cons t revacc)])))
|
|
||||||
|
|
||||||
;; Split out to provide a syntactic location to define State in
|
|
||||||
;; quit-interruptk : Reason -> (All (State) State -> (Transition State))
|
|
||||||
(define ((quit-interruptk e) old-process-state)
|
|
||||||
(transition old-process-state (quit #f e)))
|
|
||||||
|
|
||||||
;; run-ready : (All (State) (process State) (InterruptK State) -> (process State))
|
|
||||||
(define (run-ready p interruptk)
|
|
||||||
(define old-state (process-state p))
|
|
||||||
(match-define (transition new-state actions)
|
|
||||||
(send-to-user p (e) (transition old-state (quit #f e))
|
|
||||||
(interruptk old-state)))
|
|
||||||
(struct-copy process p
|
|
||||||
[state new-state]
|
|
||||||
[pending-actions (quasiqueue-append (process-pending-actions p)
|
|
||||||
(action-tree->quasiqueue actions))]))
|
|
||||||
|
|
||||||
;; notify-route-change-self : (All (SNew)
|
|
||||||
;; (process SNew)
|
|
||||||
;; (endpoint SNew)
|
|
||||||
;; (Role -> EndpointEvent)
|
|
||||||
;; ->
|
|
||||||
;; (process SNew))
|
|
||||||
(define (notify-route-change-self pn en flow->notification)
|
|
||||||
(define endpointso (process-endpoints pn))
|
|
||||||
(for/fold ([pn pn]) ([eido (in-hash-keys endpointso)])
|
|
||||||
(define eo (hash-ref endpointso eido))
|
|
||||||
(cond
|
|
||||||
[(role-intersection (endpoint-role eo) (endpoint-role en))
|
|
||||||
=> (lambda (intersecting-topic)
|
|
||||||
(define flow-toward-o (refine-role (endpoint-role en) intersecting-topic))
|
|
||||||
(define flow-toward-n (refine-role (endpoint-role eo) intersecting-topic))
|
|
||||||
(invoke-handler-if-visible (invoke-handler-if-visible pn
|
|
||||||
eo
|
|
||||||
flow-toward-o
|
|
||||||
flow->notification)
|
|
||||||
en
|
|
||||||
flow-toward-n
|
|
||||||
flow->notification))]
|
|
||||||
[else pn])))
|
|
||||||
|
|
||||||
;; notify-route-change-process : (All (SOld SNew)
|
|
||||||
;; (process SOld)
|
|
||||||
;; (process SNew)
|
|
||||||
;; (endpoint SNew)
|
|
||||||
;; (Role -> EndpointEvent)
|
|
||||||
;; -> (values (process SOld)
|
|
||||||
;; (process SNew)))
|
|
||||||
(define (notify-route-change-process po pn en flow->notification)
|
|
||||||
(define endpointso (process-endpoints po))
|
|
||||||
(for/fold ([po po]
|
|
||||||
[pn pn])
|
|
||||||
([eido (in-hash-keys endpointso)])
|
|
||||||
(define eo (hash-ref endpointso eido))
|
|
||||||
(cond
|
|
||||||
[(role-intersection (endpoint-role eo) (endpoint-role en))
|
|
||||||
=> (lambda (intersecting-topic)
|
|
||||||
(define flow-toward-o (refine-role (endpoint-role en) intersecting-topic))
|
|
||||||
(define flow-toward-n (refine-role (endpoint-role eo) intersecting-topic))
|
|
||||||
(values (invoke-handler-if-visible po eo flow-toward-o flow->notification)
|
|
||||||
(invoke-handler-if-visible pn en flow-toward-n flow->notification)))]
|
|
||||||
[else
|
|
||||||
(values po pn)])))
|
|
||||||
|
|
||||||
;; invoke-handler-if-visible : (All (State)
|
|
||||||
;; (process State)
|
|
||||||
;; (endpoint State)
|
|
||||||
;; Role
|
|
||||||
;; (Role -> EndpointEvent)
|
|
||||||
;; ->
|
|
||||||
;; (process State))
|
|
||||||
(define (invoke-handler-if-visible p ep flow flow->notification)
|
|
||||||
(if (flow-visible? (endpoint-role ep) flow)
|
|
||||||
(run-ready p (send-to-user p (e) (quit-interruptk e)
|
|
||||||
((endpoint-handler ep) (flow->notification flow))))
|
|
||||||
p))
|
|
||||||
|
|
||||||
;; notify-route-change-vm : (All (SNew)
|
|
||||||
;; (process SNew)
|
|
||||||
;; (endpoint SNew)
|
|
||||||
;; (Role -> EndpointEvent)
|
|
||||||
;; vm
|
|
||||||
;; -> (values (process SNew)
|
|
||||||
;; vm))
|
|
||||||
(define (notify-route-change-vm pn en flow->notification state)
|
|
||||||
(define old-processes (vm-processes state))
|
|
||||||
(define-values (final-pn new-processes)
|
|
||||||
(for/fold ([pn (notify-route-change-self pn en flow->notification)]
|
|
||||||
[new-processes #hash()])
|
|
||||||
([pid (in-hash-keys old-processes)])
|
|
||||||
(define wp (hash-ref old-processes pid))
|
|
||||||
(apply values
|
|
||||||
(let ((po wp))
|
|
||||||
(let-values (((po pn) (notify-route-change-process po pn en flow->notification)))
|
|
||||||
(list pn (hash-set new-processes pid po)))))))
|
|
||||||
(values final-pn
|
|
||||||
(struct-copy vm state [processes new-processes])))
|
|
||||||
|
|
||||||
;;; Local Variables:
|
|
||||||
;;; eval: (put 'send-to-user 'scheme-indent-function 3)
|
|
||||||
;;; End:
|
|
|
@ -1,45 +0,0 @@
|
||||||
#lang racket/base
|
|
||||||
|
|
||||||
(provide empty-quasiqueue
|
|
||||||
quasiqueue-empty?
|
|
||||||
quasiqueue-append-list
|
|
||||||
quasiqueue-append
|
|
||||||
quasiqueue
|
|
||||||
list->quasiqueue
|
|
||||||
quasiqueue->list
|
|
||||||
quasiqueue->cons-tree)
|
|
||||||
|
|
||||||
;; A QuasiQueue<X> is a list of Xs in *reversed* order.
|
|
||||||
;; (define-type (QuasiQueue X) (Listof X))
|
|
||||||
|
|
||||||
;; (define-type (Constreeof X) (Rec CT (U X (Pairof CT CT) False Void Null)))
|
|
||||||
|
|
||||||
;; empty-quasiqueue : (All (X) -> (QuasiQueue X))
|
|
||||||
(define (empty-quasiqueue) '())
|
|
||||||
|
|
||||||
;; quasiqueue-empty? : (All (X) (QuasiQueue X) -> Boolean)
|
|
||||||
(define (quasiqueue-empty? q) (null? q))
|
|
||||||
|
|
||||||
;; quasiqueue-append-list : (All (X) (QuasiQueue X) (Listof X) -> (QuasiQueue X))
|
|
||||||
(define (quasiqueue-append-list q xs)
|
|
||||||
(append (reverse xs) q))
|
|
||||||
|
|
||||||
;; quasiqueue-append : (All (X) (QuasiQueue X) (QuasiQueue X) -> (QuasiQueue X))
|
|
||||||
(define (quasiqueue-append q1 q2)
|
|
||||||
(append q2 q1))
|
|
||||||
|
|
||||||
;; quasiqueue : (All (X) X * -> (QuasiQueue X))
|
|
||||||
(define (quasiqueue . xs)
|
|
||||||
(reverse xs))
|
|
||||||
|
|
||||||
;; list->quasiqueue : (All (X) (Listof X) -> (QuasiQueue X))
|
|
||||||
(define (list->quasiqueue xs)
|
|
||||||
(reverse xs))
|
|
||||||
|
|
||||||
;; quasiqueue->list : (All (X) (QuasiQueue X) -> (Listof X))
|
|
||||||
(define (quasiqueue->list q)
|
|
||||||
(reverse q))
|
|
||||||
|
|
||||||
;; quasiqueue->cons-tree : (All (X) (QuasiQueue X) -> (Constreeof X))
|
|
||||||
(define (quasiqueue->cons-tree q)
|
|
||||||
(reverse q))
|
|
|
@ -0,0 +1,245 @@
|
||||||
|
|
||||||
|
/* See the beginning of "scribble.css". */
|
||||||
|
|
||||||
|
/* Monospace: */
|
||||||
|
.RktIn, .RktRdr, .RktPn, .RktMeta,
|
||||||
|
.RktMod, .RktKw, .RktVar, .RktSym,
|
||||||
|
.RktRes, .RktOut, .RktCmt, .RktVal,
|
||||||
|
.RktBlk {
|
||||||
|
font-family: monospace;
|
||||||
|
white-space: inherit;
|
||||||
|
}
|
||||||
|
|
||||||
|
/* Serif: */
|
||||||
|
.inheritedlbl {
|
||||||
|
font-family: serif;
|
||||||
|
}
|
||||||
|
|
||||||
|
/* Sans-serif: */
|
||||||
|
.RBackgroundLabelInner {
|
||||||
|
font-family: sans-serif;
|
||||||
|
}
|
||||||
|
|
||||||
|
/* ---------------------------------------- */
|
||||||
|
/* Inherited methods, left margin */
|
||||||
|
|
||||||
|
.inherited {
|
||||||
|
width: 100%;
|
||||||
|
margin-top: 0.5em;
|
||||||
|
text-align: left;
|
||||||
|
background-color: #ECF5F5;
|
||||||
|
}
|
||||||
|
|
||||||
|
.inherited td {
|
||||||
|
font-size: 82%;
|
||||||
|
padding-left: 1em;
|
||||||
|
text-indent: -0.8em;
|
||||||
|
padding-right: 0.2em;
|
||||||
|
}
|
||||||
|
|
||||||
|
.inheritedlbl {
|
||||||
|
font-style: italic;
|
||||||
|
}
|
||||||
|
|
||||||
|
/* ---------------------------------------- */
|
||||||
|
/* Racket text styles */
|
||||||
|
|
||||||
|
.RktIn {
|
||||||
|
color: #cc6633;
|
||||||
|
background-color: #eeeeee;
|
||||||
|
}
|
||||||
|
|
||||||
|
.RktInBG {
|
||||||
|
background-color: #eeeeee;
|
||||||
|
}
|
||||||
|
|
||||||
|
.RktRdr {
|
||||||
|
}
|
||||||
|
|
||||||
|
.RktPn {
|
||||||
|
color: #843c24;
|
||||||
|
}
|
||||||
|
|
||||||
|
.RktMeta {
|
||||||
|
color: black;
|
||||||
|
}
|
||||||
|
|
||||||
|
.RktMod {
|
||||||
|
color: black;
|
||||||
|
}
|
||||||
|
|
||||||
|
.RktOpt {
|
||||||
|
color: black;
|
||||||
|
}
|
||||||
|
|
||||||
|
.RktKw {
|
||||||
|
color: black;
|
||||||
|
}
|
||||||
|
|
||||||
|
.RktErr {
|
||||||
|
color: red;
|
||||||
|
font-style: italic;
|
||||||
|
}
|
||||||
|
|
||||||
|
.RktVar {
|
||||||
|
color: #262680;
|
||||||
|
font-style: italic;
|
||||||
|
}
|
||||||
|
|
||||||
|
.RktSym {
|
||||||
|
color: #262680;
|
||||||
|
}
|
||||||
|
|
||||||
|
.RktSymDef { /* used with RktSym at def site */
|
||||||
|
}
|
||||||
|
|
||||||
|
.RktValLink {
|
||||||
|
text-decoration: none;
|
||||||
|
color: blue;
|
||||||
|
}
|
||||||
|
|
||||||
|
.RktValDef { /* used with RktValLink at def site */
|
||||||
|
}
|
||||||
|
|
||||||
|
.RktModLink {
|
||||||
|
text-decoration: none;
|
||||||
|
color: blue;
|
||||||
|
}
|
||||||
|
|
||||||
|
.RktStxLink {
|
||||||
|
text-decoration: none;
|
||||||
|
color: black;
|
||||||
|
}
|
||||||
|
|
||||||
|
.RktStxDef { /* used with RktStxLink at def site */
|
||||||
|
}
|
||||||
|
|
||||||
|
.RktRes {
|
||||||
|
color: #0000af;
|
||||||
|
}
|
||||||
|
|
||||||
|
.RktOut {
|
||||||
|
color: #960096;
|
||||||
|
}
|
||||||
|
|
||||||
|
.RktCmt {
|
||||||
|
color: #c2741f;
|
||||||
|
}
|
||||||
|
|
||||||
|
.RktVal {
|
||||||
|
color: #228b22;
|
||||||
|
}
|
||||||
|
|
||||||
|
/* ---------------------------------------- */
|
||||||
|
/* Some inline styles */
|
||||||
|
|
||||||
|
.together {
|
||||||
|
width: 100%;
|
||||||
|
}
|
||||||
|
|
||||||
|
.prototype, .argcontract, .RBoxed {
|
||||||
|
white-space: nowrap;
|
||||||
|
}
|
||||||
|
|
||||||
|
.prototype td {
|
||||||
|
vertical-align: text-top;
|
||||||
|
}
|
||||||
|
.longprototype td {
|
||||||
|
vertical-align: bottom;
|
||||||
|
}
|
||||||
|
|
||||||
|
.RktBlk {
|
||||||
|
white-space: inherit;
|
||||||
|
text-align: left;
|
||||||
|
}
|
||||||
|
|
||||||
|
.RktBlk tr {
|
||||||
|
white-space: inherit;
|
||||||
|
}
|
||||||
|
|
||||||
|
.RktBlk td {
|
||||||
|
vertical-align: baseline;
|
||||||
|
white-space: inherit;
|
||||||
|
}
|
||||||
|
|
||||||
|
.argcontract td {
|
||||||
|
vertical-align: text-top;
|
||||||
|
}
|
||||||
|
|
||||||
|
.highlighted {
|
||||||
|
background-color: #ddddff;
|
||||||
|
}
|
||||||
|
|
||||||
|
.defmodule {
|
||||||
|
width: 100%;
|
||||||
|
background-color: #F5F5DC;
|
||||||
|
}
|
||||||
|
|
||||||
|
.specgrammar {
|
||||||
|
float: right;
|
||||||
|
}
|
||||||
|
|
||||||
|
.RBibliography td {
|
||||||
|
vertical-align: text-top;
|
||||||
|
}
|
||||||
|
|
||||||
|
.leftindent {
|
||||||
|
margin-left: 1em;
|
||||||
|
margin-right: 0em;
|
||||||
|
}
|
||||||
|
|
||||||
|
.insetpara {
|
||||||
|
margin-left: 1em;
|
||||||
|
margin-right: 1em;
|
||||||
|
}
|
||||||
|
|
||||||
|
.Rfilebox {
|
||||||
|
}
|
||||||
|
|
||||||
|
.Rfiletitle {
|
||||||
|
text-align: right;
|
||||||
|
margin: 0em 0em 0em 0em;
|
||||||
|
}
|
||||||
|
|
||||||
|
.Rfilename {
|
||||||
|
border-top: 1px solid #6C8585;
|
||||||
|
border-right: 1px solid #6C8585;
|
||||||
|
padding-left: 0.5em;
|
||||||
|
padding-right: 0.5em;
|
||||||
|
background-color: #ECF5F5;
|
||||||
|
}
|
||||||
|
|
||||||
|
.Rfilecontent {
|
||||||
|
margin: 0em 0em 0em 0em;
|
||||||
|
}
|
||||||
|
|
||||||
|
.RpackageSpec {
|
||||||
|
padding-right: 0.5em;
|
||||||
|
}
|
||||||
|
|
||||||
|
/* ---------------------------------------- */
|
||||||
|
/* For background labels */
|
||||||
|
|
||||||
|
.RBackgroundLabel {
|
||||||
|
float: right;
|
||||||
|
width: 0px;
|
||||||
|
height: 0px;
|
||||||
|
}
|
||||||
|
|
||||||
|
.RBackgroundLabelInner {
|
||||||
|
position: relative;
|
||||||
|
width: 25em;
|
||||||
|
left: -25.5em;
|
||||||
|
top: 0px;
|
||||||
|
text-align: right;
|
||||||
|
color: white;
|
||||||
|
z-index: 0;
|
||||||
|
font-weight: bold;
|
||||||
|
}
|
||||||
|
|
||||||
|
.RForeground {
|
||||||
|
position: relative;
|
||||||
|
left: 0px;
|
||||||
|
top: 0px;
|
||||||
|
z-index: 1;
|
||||||
|
}
|
73
roles.rkt
73
roles.rkt
|
@ -1,73 +0,0 @@
|
||||||
#lang racket/base
|
|
||||||
|
|
||||||
(require racket/match)
|
|
||||||
(require "structs.rkt")
|
|
||||||
(require "log.rkt")
|
|
||||||
(require "unify.rkt")
|
|
||||||
|
|
||||||
(provide co-orientations
|
|
||||||
co-roles
|
|
||||||
refine-role
|
|
||||||
roles-equal?
|
|
||||||
orientations-intersect?
|
|
||||||
role-intersection
|
|
||||||
flow-visible?)
|
|
||||||
|
|
||||||
;; co-orientations : Orientation -> (Listof Orientation)
|
|
||||||
(define (co-orientations o)
|
|
||||||
(match o
|
|
||||||
['publisher '(subscriber)]
|
|
||||||
['subscriber '(publisher)]))
|
|
||||||
|
|
||||||
;; co-roles : Role -> (Listof Role)
|
|
||||||
(define (co-roles r)
|
|
||||||
(for/list ([co-orientation (co-orientations (role-orientation r))])
|
|
||||||
(struct-copy role r [orientation co-orientation])))
|
|
||||||
|
|
||||||
;; refine-role : Role Topic -> Role
|
|
||||||
(define (refine-role remote-role new-topic)
|
|
||||||
(struct-copy role remote-role [topic new-topic]))
|
|
||||||
|
|
||||||
;; roles-equal? : Role Role -> Boolean
|
|
||||||
(define (roles-equal? ta tb)
|
|
||||||
(and (equal? (role-orientation ta) (role-orientation tb))
|
|
||||||
(equal? (role-interest-type ta) (role-interest-type tb))
|
|
||||||
(specialization? (role-topic ta) (role-topic tb))
|
|
||||||
(specialization? (role-topic tb) (role-topic ta))))
|
|
||||||
|
|
||||||
;; orientations-intersect? : Orientation Orientation -> Boolean
|
|
||||||
(define (orientations-intersect? l r)
|
|
||||||
(and (memq l (co-orientations r)) #t))
|
|
||||||
|
|
||||||
;; "Both left and right must be canonicalized." - comment from os2.rkt. What does it mean?
|
|
||||||
;; role-intersection : Role Role -> (Option Topic)
|
|
||||||
(define (role-intersection left right)
|
|
||||||
(define result
|
|
||||||
(and (orientations-intersect? (role-orientation left) (role-orientation right))
|
|
||||||
(mgu-canonical (freshen (role-topic left)) (freshen (role-topic right)))))
|
|
||||||
(marketplace-log 'debug "role-intersection ~v // ~v --> ~v" left right result)
|
|
||||||
result)
|
|
||||||
|
|
||||||
;; True iff the flow between remote-role and local-role should be
|
|
||||||
;; visible to the local peer. This is the case when either local-role
|
|
||||||
;; is monitoring 'everything or otherwise if remote-role is a
|
|
||||||
;; 'participant only.
|
|
||||||
;;
|
|
||||||
;; |--------------+--------------+------------------------|
|
|
||||||
;; | local-role | remote-role | visible to local peer? |
|
|
||||||
;; |--------------+--------------+------------------------|
|
|
||||||
;; | 'participant | 'participant | yes |
|
|
||||||
;; | 'participant | 'observer | no |
|
|
||||||
;; | 'participant | 'everything | no |
|
|
||||||
;; | 'observer | 'participant | yes |
|
|
||||||
;; | 'observer | 'observer | no |
|
|
||||||
;; | 'observer | 'everything | no |
|
|
||||||
;; | 'everything | 'participant | yes |
|
|
||||||
;; | 'everything | 'observer | yes |
|
|
||||||
;; | 'everything | 'everything | yes |
|
|
||||||
;; |--------------+--------------+------------------------|
|
|
||||||
;;
|
|
||||||
;; flow-visible? : Role Role -> Boolean
|
|
||||||
(define (flow-visible? local-role remote-role)
|
|
||||||
(or (eq? (role-interest-type remote-role) 'participant)
|
|
||||||
(eq? (role-interest-type local-role) 'everything)))
|
|
|
@ -0,0 +1,153 @@
|
||||||
|
// Common functionality for PLT documentation pages
|
||||||
|
|
||||||
|
// Page Parameters ------------------------------------------------------------
|
||||||
|
|
||||||
|
var page_query_string =
|
||||||
|
(location.href.search(/\?([^#]+)(?:#|$)/) >= 0) && RegExp.$1;
|
||||||
|
|
||||||
|
var page_args =
|
||||||
|
((function(){
|
||||||
|
if (!page_query_string) return [];
|
||||||
|
var args = page_query_string.split(/[&;]/);
|
||||||
|
for (var i=0; i<args.length; i++) {
|
||||||
|
var a = args[i];
|
||||||
|
var p = a.indexOf('=');
|
||||||
|
if (p >= 0) args[i] = [a.substring(0,p), a.substring(p+1)];
|
||||||
|
else args[i] = [a, false];
|
||||||
|
}
|
||||||
|
return args;
|
||||||
|
})());
|
||||||
|
|
||||||
|
function GetPageArg(key, def) {
|
||||||
|
for (var i=0; i<page_args.length; i++)
|
||||||
|
if (page_args[i][0] == key) return unescape(page_args[i][1]);
|
||||||
|
return def;
|
||||||
|
}
|
||||||
|
|
||||||
|
function MergePageArgsIntoLink(a) {
|
||||||
|
if (page_args.length == 0 ||
|
||||||
|
(!a.attributes["data-pltdoc"]) || (a.attributes["data-pltdoc"].value == ""))
|
||||||
|
return;
|
||||||
|
a.href.search(/^([^?#]*)(?:\?([^#]*))?(#.*)?$/);
|
||||||
|
if (RegExp.$2.length == 0) {
|
||||||
|
a.href = RegExp.$1 + "?" + page_query_string + RegExp.$3;
|
||||||
|
} else {
|
||||||
|
// need to merge here, precedence to arguments that exist in `a'
|
||||||
|
var i, j;
|
||||||
|
var prefix = RegExp.$1, str = RegExp.$2, suffix = RegExp.$3;
|
||||||
|
var args = str.split(/[&;]/);
|
||||||
|
for (i=0; i<args.length; i++) {
|
||||||
|
j = args[i].indexOf('=');
|
||||||
|
if (j) args[i] = args[i].substring(0,j);
|
||||||
|
}
|
||||||
|
var additions = "";
|
||||||
|
for (i=0; i<page_args.length; i++) {
|
||||||
|
var exists = false;
|
||||||
|
for (j=0; j<args.length; j++)
|
||||||
|
if (args[j] == page_args[i][0]) { exists = true; break; }
|
||||||
|
if (!exists) str += "&" + page_args[i][0] + "=" + page_args[i][1];
|
||||||
|
}
|
||||||
|
a.href = prefix + "?" + str + suffix;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
// Cookies --------------------------------------------------------------------
|
||||||
|
|
||||||
|
function GetCookie(key, def) {
|
||||||
|
var i, cookiestrs;
|
||||||
|
try {
|
||||||
|
if (document.cookie.length <= 0) return def;
|
||||||
|
cookiestrs = document.cookie.split(/; */);
|
||||||
|
} catch (e) { return def; }
|
||||||
|
for (i = 0; i < cookiestrs.length; i++) {
|
||||||
|
var cur = cookiestrs[i];
|
||||||
|
var eql = cur.indexOf('=');
|
||||||
|
if (eql >= 0 && cur.substring(0,eql) == key)
|
||||||
|
return unescape(cur.substring(eql+1));
|
||||||
|
}
|
||||||
|
return def;
|
||||||
|
}
|
||||||
|
|
||||||
|
function SetCookie(key, val) {
|
||||||
|
var d = new Date();
|
||||||
|
d.setTime(d.getTime()+(365*24*60*60*1000));
|
||||||
|
try {
|
||||||
|
document.cookie =
|
||||||
|
key + "=" + escape(val) + "; expires="+ d.toGMTString() + "; path=/";
|
||||||
|
} catch (e) {}
|
||||||
|
}
|
||||||
|
|
||||||
|
// note that this always stores a directory name, ending with a "/"
|
||||||
|
function SetPLTRoot(ver, relative) {
|
||||||
|
var root = location.protocol + "//" + location.host
|
||||||
|
+ NormalizePath(location.pathname.replace(/[^\/]*$/, relative));
|
||||||
|
SetCookie("PLT_Root."+ver, root);
|
||||||
|
}
|
||||||
|
|
||||||
|
// adding index.html works because of the above
|
||||||
|
function GotoPLTRoot(ver, relative) {
|
||||||
|
var u = GetCookie("PLT_Root."+ver, null);
|
||||||
|
if (u == null) return true; // no cookie: use plain up link
|
||||||
|
// the relative path is optional, default goes to the toplevel start page
|
||||||
|
if (!relative) relative = "index.html";
|
||||||
|
location = u + relative;
|
||||||
|
return false;
|
||||||
|
}
|
||||||
|
|
||||||
|
// Utilities ------------------------------------------------------------------
|
||||||
|
|
||||||
|
var normalize_rxs = [/\/\/+/g, /\/\.(\/|$)/, /\/[^\/]*\/\.\.(\/|$)/];
|
||||||
|
function NormalizePath(path) {
|
||||||
|
var tmp, i;
|
||||||
|
for (i = 0; i < normalize_rxs.length; i++)
|
||||||
|
while ((tmp = path.replace(normalize_rxs[i], "/")) != path) path = tmp;
|
||||||
|
return path;
|
||||||
|
}
|
||||||
|
|
||||||
|
// `noscript' is problematic in some browsers (always renders as a
|
||||||
|
// block), use this hack instead (does not always work!)
|
||||||
|
// document.write("<style>mynoscript { display:none; }</style>");
|
||||||
|
|
||||||
|
// Interactions ---------------------------------------------------------------
|
||||||
|
|
||||||
|
function DoSearchKey(event, field, ver, top_path) {
|
||||||
|
var val = field.value;
|
||||||
|
if (event && event.keyCode == 13) {
|
||||||
|
var u = GetCookie("PLT_Root."+ver, null);
|
||||||
|
if (u == null) u = top_path; // default: go to the top path
|
||||||
|
u += "search/index.html?q=" + escape(val);
|
||||||
|
if (page_query_string) u += "&" + page_query_string;
|
||||||
|
location = u;
|
||||||
|
return false;
|
||||||
|
}
|
||||||
|
return true;
|
||||||
|
}
|
||||||
|
|
||||||
|
function TocviewToggle(glyph, id) {
|
||||||
|
var s = document.getElementById(id).style;
|
||||||
|
var expand = s.display == "none";
|
||||||
|
s.display = expand ? "block" : "none";
|
||||||
|
glyph.innerHTML = expand ? "▼" : "►";
|
||||||
|
}
|
||||||
|
|
||||||
|
// Page Init ------------------------------------------------------------------
|
||||||
|
|
||||||
|
// Note: could make a function that inspects and uses window.onload to chain to
|
||||||
|
// a previous one, but this file needs to be required first anyway, since it
|
||||||
|
// contains utilities for all other files.
|
||||||
|
var on_load_funcs = [];
|
||||||
|
function AddOnLoad(fun) { on_load_funcs.push(fun); }
|
||||||
|
window.onload = function() {
|
||||||
|
for (var i=0; i<on_load_funcs.length; i++) on_load_funcs[i]();
|
||||||
|
};
|
||||||
|
|
||||||
|
AddOnLoad(function(){
|
||||||
|
var links = document.getElementsByTagName("a");
|
||||||
|
for (var i=0; i<links.length; i++) MergePageArgsIntoLink(links[i]);
|
||||||
|
var label = GetPageArg("ctxtname",false);
|
||||||
|
if (!label) return;
|
||||||
|
var indicator = document.getElementById("contextindicator");
|
||||||
|
if (!indicator) return;
|
||||||
|
indicator.innerHTML = label;
|
||||||
|
indicator.style.display = "block";
|
||||||
|
});
|
|
@ -0,0 +1,480 @@
|
||||||
|
|
||||||
|
/* This file is used by default by all Scribble documents.
|
||||||
|
See also "manual.css", which is added by default by the
|
||||||
|
`scribble/manual` language. */
|
||||||
|
|
||||||
|
/* CSS seems backward: List all the classes for which we want a
|
||||||
|
particular font, so that the font can be changed in one place. (It
|
||||||
|
would be nicer to reference a font definition from all the places
|
||||||
|
that we want it.)
|
||||||
|
|
||||||
|
As you read the rest of the file, remember to double-check here to
|
||||||
|
see if any font is set. */
|
||||||
|
|
||||||
|
/* Monospace: */
|
||||||
|
.maincolumn, .refpara, .refelem, .tocset, .stt, .hspace, .refparaleft, .refelemleft {
|
||||||
|
font-family: monospace;
|
||||||
|
}
|
||||||
|
|
||||||
|
/* Serif: */
|
||||||
|
.main, .refcontent, .tocview, .tocsub, .sroman, i {
|
||||||
|
font-family: serif;
|
||||||
|
}
|
||||||
|
|
||||||
|
/* Sans-serif: */
|
||||||
|
.version, .versionNoNav, .ssansserif {
|
||||||
|
font-family: sans-serif;
|
||||||
|
}
|
||||||
|
.ssansserif {
|
||||||
|
font-size: 80%;
|
||||||
|
font-weight: bold;
|
||||||
|
}
|
||||||
|
|
||||||
|
/* ---------------------------------------- */
|
||||||
|
|
||||||
|
p, .SIntrapara {
|
||||||
|
display: block;
|
||||||
|
margin: 1em 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
h2 { /* per-page main title */
|
||||||
|
margin-top: 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
h3, h4, h5, h6, h7, h8 {
|
||||||
|
margin-top: 1.75em;
|
||||||
|
margin-bottom: 0.5em;
|
||||||
|
}
|
||||||
|
|
||||||
|
.SSubSubSubSection {
|
||||||
|
font-weight: bold;
|
||||||
|
font-size: 0.83em; /* should match h5; from HTML 4 reference */
|
||||||
|
}
|
||||||
|
|
||||||
|
/* Needed for browsers like Opera, and eventually for HTML 4 conformance.
|
||||||
|
This means that multiple paragraphs in a table element do not have a space
|
||||||
|
between them. */
|
||||||
|
table p {
|
||||||
|
margin-top: 0;
|
||||||
|
margin-bottom: 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
/* ---------------------------------------- */
|
||||||
|
/* Main */
|
||||||
|
|
||||||
|
body {
|
||||||
|
color: black;
|
||||||
|
background-color: #ffffff;
|
||||||
|
}
|
||||||
|
|
||||||
|
table td {
|
||||||
|
padding-left: 0;
|
||||||
|
padding-right: 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
.maincolumn {
|
||||||
|
width: 43em;
|
||||||
|
margin-right: -40em;
|
||||||
|
margin-left: 15em;
|
||||||
|
}
|
||||||
|
|
||||||
|
.main {
|
||||||
|
text-align: left;
|
||||||
|
}
|
||||||
|
|
||||||
|
/* ---------------------------------------- */
|
||||||
|
/* Navigation */
|
||||||
|
|
||||||
|
.navsettop, .navsetbottom {
|
||||||
|
background-color: #f0f0e0;
|
||||||
|
padding: 0.25em 0 0.25em 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
.navsettop {
|
||||||
|
margin-bottom: 1.5em;
|
||||||
|
border-bottom: 2px solid #e0e0c0;
|
||||||
|
}
|
||||||
|
|
||||||
|
.navsetbottom {
|
||||||
|
margin-top: 2em;
|
||||||
|
border-top: 2px solid #e0e0c0;
|
||||||
|
}
|
||||||
|
|
||||||
|
.navleft {
|
||||||
|
margin-left: 1ex;
|
||||||
|
position: relative;
|
||||||
|
float: left;
|
||||||
|
white-space: nowrap;
|
||||||
|
}
|
||||||
|
.navright {
|
||||||
|
margin-right: 1ex;
|
||||||
|
position: relative;
|
||||||
|
float: right;
|
||||||
|
white-space: nowrap;
|
||||||
|
}
|
||||||
|
.nonavigation {
|
||||||
|
color: #e0e0e0;
|
||||||
|
}
|
||||||
|
|
||||||
|
.searchform {
|
||||||
|
display: inline;
|
||||||
|
margin: 0;
|
||||||
|
padding: 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
.searchbox {
|
||||||
|
width: 16em;
|
||||||
|
margin: 0px;
|
||||||
|
padding: 0px;
|
||||||
|
background-color: #eee;
|
||||||
|
border: 1px solid #ddd;
|
||||||
|
text-align: center;
|
||||||
|
vertical-align: middle;
|
||||||
|
}
|
||||||
|
|
||||||
|
#contextindicator {
|
||||||
|
position: fixed;
|
||||||
|
background-color: #c6f;
|
||||||
|
color: #000;
|
||||||
|
font-family: monospace;
|
||||||
|
font-weight: bold;
|
||||||
|
padding: 2px 10px;
|
||||||
|
display: none;
|
||||||
|
right: 0;
|
||||||
|
bottom: 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
/* ---------------------------------------- */
|
||||||
|
/* Version */
|
||||||
|
|
||||||
|
.versionbox {
|
||||||
|
position: relative;
|
||||||
|
float: right;
|
||||||
|
left: 2em;
|
||||||
|
height: 0em;
|
||||||
|
width: 13em;
|
||||||
|
margin: 0em -13em 0em 0em;
|
||||||
|
}
|
||||||
|
.version {
|
||||||
|
font-size: small;
|
||||||
|
}
|
||||||
|
.versionNoNav {
|
||||||
|
font-size: xx-small; /* avoid overlap with author */
|
||||||
|
}
|
||||||
|
|
||||||
|
.version:before, .versionNoNav:before {
|
||||||
|
content: "Version ";
|
||||||
|
}
|
||||||
|
|
||||||
|
/* ---------------------------------------- */
|
||||||
|
/* Margin notes */
|
||||||
|
|
||||||
|
.refpara, .refelem {
|
||||||
|
position: relative;
|
||||||
|
float: right;
|
||||||
|
left: 2em;
|
||||||
|
height: 0em;
|
||||||
|
width: 13em;
|
||||||
|
margin: 0em -13em 0em 0em;
|
||||||
|
}
|
||||||
|
|
||||||
|
.refpara, .refparaleft {
|
||||||
|
top: -1em;
|
||||||
|
}
|
||||||
|
|
||||||
|
.refcolumn {
|
||||||
|
background-color: #F5F5DC;
|
||||||
|
display: block;
|
||||||
|
position: relative;
|
||||||
|
width: 13em;
|
||||||
|
font-size: 85%;
|
||||||
|
border: 0.5em solid #F5F5DC;
|
||||||
|
margin: 0 0 0 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
.refcontent {
|
||||||
|
margin: 0 0 0 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
.refcontent p {
|
||||||
|
margin-top: 0;
|
||||||
|
margin-bottom: 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
.refparaleft, .refelemleft {
|
||||||
|
position: relative;
|
||||||
|
float: left;
|
||||||
|
right: 2em;
|
||||||
|
height: 0em;
|
||||||
|
width: 13em;
|
||||||
|
margin: 0em 0em 0em -13em;
|
||||||
|
}
|
||||||
|
|
||||||
|
.refcolumnleft {
|
||||||
|
background-color: #F5F5DC;
|
||||||
|
display: block;
|
||||||
|
position: relative;
|
||||||
|
width: 13em;
|
||||||
|
font-size: 85%;
|
||||||
|
border: 0.5em solid #F5F5DC;
|
||||||
|
margin: 0 0 0 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
/* ---------------------------------------- */
|
||||||
|
/* Table of contents, inline */
|
||||||
|
|
||||||
|
.toclink {
|
||||||
|
text-decoration: none;
|
||||||
|
color: blue;
|
||||||
|
font-size: 85%;
|
||||||
|
}
|
||||||
|
|
||||||
|
.toptoclink {
|
||||||
|
text-decoration: none;
|
||||||
|
color: blue;
|
||||||
|
font-weight: bold;
|
||||||
|
}
|
||||||
|
|
||||||
|
/* ---------------------------------------- */
|
||||||
|
/* Table of contents, left margin */
|
||||||
|
|
||||||
|
.tocset {
|
||||||
|
position: relative;
|
||||||
|
float: left;
|
||||||
|
width: 12.5em;
|
||||||
|
margin-right: 2em;
|
||||||
|
}
|
||||||
|
.tocset td {
|
||||||
|
vertical-align: text-top;
|
||||||
|
}
|
||||||
|
|
||||||
|
.tocview {
|
||||||
|
text-align: left;
|
||||||
|
background-color: #f0f0e0;
|
||||||
|
}
|
||||||
|
|
||||||
|
.tocsub {
|
||||||
|
text-align: left;
|
||||||
|
margin-top: 0.5em;
|
||||||
|
background-color: #f0f0e0;
|
||||||
|
}
|
||||||
|
|
||||||
|
.tocviewlist, .tocsublist {
|
||||||
|
margin-left: 0.2em;
|
||||||
|
margin-right: 0.2em;
|
||||||
|
padding-top: 0.2em;
|
||||||
|
padding-bottom: 0.2em;
|
||||||
|
}
|
||||||
|
.tocviewlist table {
|
||||||
|
font-size: 82%;
|
||||||
|
}
|
||||||
|
|
||||||
|
.tocviewlisttopspace {
|
||||||
|
margin-bottom: 1em;
|
||||||
|
}
|
||||||
|
|
||||||
|
.tocviewsublist, .tocviewsublistonly, .tocviewsublisttop, .tocviewsublistbottom {
|
||||||
|
margin-left: 0.4em;
|
||||||
|
border-left: 1px solid #bbf;
|
||||||
|
padding-left: 0.8em;
|
||||||
|
}
|
||||||
|
.tocviewsublist {
|
||||||
|
margin-bottom: 1em;
|
||||||
|
}
|
||||||
|
.tocviewsublist table,
|
||||||
|
.tocviewsublistonly table,
|
||||||
|
.tocviewsublisttop table,
|
||||||
|
.tocviewsublistbottom table {
|
||||||
|
font-size: 75%;
|
||||||
|
}
|
||||||
|
|
||||||
|
.tocviewtitle * {
|
||||||
|
font-weight: bold;
|
||||||
|
}
|
||||||
|
|
||||||
|
.tocviewlink {
|
||||||
|
text-decoration: none;
|
||||||
|
color: blue;
|
||||||
|
}
|
||||||
|
|
||||||
|
.tocviewselflink {
|
||||||
|
text-decoration: underline;
|
||||||
|
color: blue;
|
||||||
|
}
|
||||||
|
|
||||||
|
.tocviewtoggle {
|
||||||
|
text-decoration: none;
|
||||||
|
color: blue;
|
||||||
|
font-size: 75%; /* looks better, and avoids bounce when toggling sub-sections due to font alignments */
|
||||||
|
}
|
||||||
|
|
||||||
|
.tocsublist td {
|
||||||
|
padding-left: 1em;
|
||||||
|
text-indent: -1em;
|
||||||
|
}
|
||||||
|
|
||||||
|
.tocsublinknumber {
|
||||||
|
font-size: 82%;
|
||||||
|
}
|
||||||
|
|
||||||
|
.tocsublink {
|
||||||
|
font-size: 82%;
|
||||||
|
text-decoration: none;
|
||||||
|
}
|
||||||
|
|
||||||
|
.tocsubseclink {
|
||||||
|
font-size: 82%;
|
||||||
|
text-decoration: none;
|
||||||
|
}
|
||||||
|
|
||||||
|
.tocsubnonseclink {
|
||||||
|
font-size: 82%;
|
||||||
|
text-decoration: none;
|
||||||
|
padding-left: 0.5em;
|
||||||
|
}
|
||||||
|
|
||||||
|
.tocsubtitle {
|
||||||
|
font-size: 82%;
|
||||||
|
font-style: italic;
|
||||||
|
margin: 0.2em;
|
||||||
|
}
|
||||||
|
|
||||||
|
/* ---------------------------------------- */
|
||||||
|
/* Some inline styles */
|
||||||
|
|
||||||
|
.indexlink {
|
||||||
|
text-decoration: none;
|
||||||
|
}
|
||||||
|
|
||||||
|
.nobreak {
|
||||||
|
white-space: nowrap;
|
||||||
|
}
|
||||||
|
|
||||||
|
pre { margin-left: 2em; }
|
||||||
|
blockquote { margin-left: 2em; }
|
||||||
|
|
||||||
|
ol { list-style-type: decimal; }
|
||||||
|
ol ol { list-style-type: lower-alpha; }
|
||||||
|
ol ol ol { list-style-type: lower-roman; }
|
||||||
|
ol ol ol ol { list-style-type: upper-alpha; }
|
||||||
|
|
||||||
|
.SCodeFlow {
|
||||||
|
display: block;
|
||||||
|
margin-left: 1em;
|
||||||
|
margin-bottom: 0em;
|
||||||
|
margin-right: 1em;
|
||||||
|
margin-top: 0em;
|
||||||
|
white-space: nowrap;
|
||||||
|
}
|
||||||
|
|
||||||
|
.SVInsetFlow {
|
||||||
|
display: block;
|
||||||
|
margin-left: 0em;
|
||||||
|
margin-bottom: 0em;
|
||||||
|
margin-right: 0em;
|
||||||
|
margin-top: 0em;
|
||||||
|
}
|
||||||
|
|
||||||
|
.SubFlow {
|
||||||
|
display: block;
|
||||||
|
margin: 0em;
|
||||||
|
}
|
||||||
|
|
||||||
|
.boxed {
|
||||||
|
width: 100%;
|
||||||
|
background-color: #E8E8FF;
|
||||||
|
}
|
||||||
|
|
||||||
|
.hspace {
|
||||||
|
}
|
||||||
|
|
||||||
|
.slant {
|
||||||
|
font-style: oblique;
|
||||||
|
}
|
||||||
|
|
||||||
|
.badlink {
|
||||||
|
text-decoration: underline;
|
||||||
|
color: red;
|
||||||
|
}
|
||||||
|
|
||||||
|
.plainlink {
|
||||||
|
text-decoration: none;
|
||||||
|
color: blue;
|
||||||
|
}
|
||||||
|
|
||||||
|
.techoutside { text-decoration: underline; color: #b0b0b0; }
|
||||||
|
.techoutside:hover { text-decoration: underline; color: blue; }
|
||||||
|
|
||||||
|
/* .techinside:hover doesn't work with FF, .techinside:hover>
|
||||||
|
.techinside doesn't work with IE, so use both (and IE doesn't
|
||||||
|
work with inherit in the second one, so use blue directly) */
|
||||||
|
.techinside { color: black; }
|
||||||
|
.techinside:hover { color: blue; }
|
||||||
|
.techoutside:hover>.techinside { color: inherit; }
|
||||||
|
|
||||||
|
.SCentered {
|
||||||
|
text-align: center;
|
||||||
|
}
|
||||||
|
|
||||||
|
.imageleft {
|
||||||
|
float: left;
|
||||||
|
margin-right: 0.3em;
|
||||||
|
}
|
||||||
|
|
||||||
|
.Smaller {
|
||||||
|
font-size: 82%;
|
||||||
|
}
|
||||||
|
|
||||||
|
.Larger {
|
||||||
|
font-size: 122%;
|
||||||
|
}
|
||||||
|
|
||||||
|
/* A hack, inserted to break some Scheme ids: */
|
||||||
|
.mywbr {
|
||||||
|
display: inline-block;
|
||||||
|
height: 0;
|
||||||
|
width: 0;
|
||||||
|
font-size: 1px;
|
||||||
|
}
|
||||||
|
|
||||||
|
.compact li p {
|
||||||
|
margin: 0em;
|
||||||
|
padding: 0em;
|
||||||
|
}
|
||||||
|
|
||||||
|
.noborder img {
|
||||||
|
border: 0;
|
||||||
|
}
|
||||||
|
|
||||||
|
.SAuthorListBox {
|
||||||
|
position: relative;
|
||||||
|
float: right;
|
||||||
|
left: 2em;
|
||||||
|
top: -2.5em;
|
||||||
|
height: 0em;
|
||||||
|
width: 13em;
|
||||||
|
margin: 0em -13em 0em 0em;
|
||||||
|
}
|
||||||
|
.SAuthorList {
|
||||||
|
font-size: 82%;
|
||||||
|
}
|
||||||
|
.SAuthorList:before {
|
||||||
|
content: "by ";
|
||||||
|
}
|
||||||
|
.author {
|
||||||
|
display: inline;
|
||||||
|
white-space: nowrap;
|
||||||
|
}
|
||||||
|
|
||||||
|
/* print styles : hide the navigation elements */
|
||||||
|
@media print {
|
||||||
|
.tocset,
|
||||||
|
.navsettop,
|
||||||
|
.navsetbottom { display: none; }
|
||||||
|
.maincolumn {
|
||||||
|
width: auto;
|
||||||
|
margin-right: 13em;
|
||||||
|
margin-left: 0;
|
||||||
|
}
|
||||||
|
}
|
|
@ -1 +0,0 @@
|
||||||
out/
|
|
|
@ -1,29 +0,0 @@
|
||||||
all: out
|
|
||||||
|
|
||||||
pages:
|
|
||||||
@(git branch -v | grep -q gh-pages || (echo local gh-pages branch missing; false))
|
|
||||||
@echo
|
|
||||||
@git branch -av | grep gh-pages
|
|
||||||
@echo
|
|
||||||
@(echo 'Is the branch up to date? Press enter to continue.'; read dummy)
|
|
||||||
git clone -b gh-pages .. pages
|
|
||||||
|
|
||||||
publish: out pages
|
|
||||||
rm -rf pages/*
|
|
||||||
cp -r out/marketplace/. pages/.
|
|
||||||
(cd pages; git add -A)
|
|
||||||
-(cd pages; git commit -m "Update $$(date +%Y%m%d%H%M%S)")
|
|
||||||
(cd pages; git push)
|
|
||||||
rm -rf pages
|
|
||||||
|
|
||||||
out:
|
|
||||||
raco scribble \
|
|
||||||
--htmls \
|
|
||||||
--dest out \
|
|
||||||
++main-xref-in \
|
|
||||||
--redirect-main http://docs.racket-lang.org/ \
|
|
||||||
\
|
|
||||||
marketplace.scrbl
|
|
||||||
|
|
||||||
clean:
|
|
||||||
rm -rf out
|
|
|
@ -1,115 +0,0 @@
|
||||||
#lang scribble/manual
|
|
||||||
@require[racket/include]
|
|
||||||
@include{prelude.inc}
|
|
||||||
|
|
||||||
@title{Background}
|
|
||||||
|
|
||||||
@section{Network programming in the small}
|
|
||||||
|
|
||||||
Even the simplest of programs can be seen as a network. This program
|
|
||||||
sends a message containing @racket[3] and @racket[4] to @racket[+],
|
|
||||||
and awaits a reply message, which contains @racket[7]:
|
|
||||||
|
|
||||||
@interaction[(+ 3 4)]
|
|
||||||
|
|
||||||
Subroutines are network services. Here, when the message @racket[3] is
|
|
||||||
sent to @racket[add-four-to], it delegates to @racket[+]:
|
|
||||||
|
|
||||||
@interaction[(define (add-four-to n) (+ n 4))
|
|
||||||
(add-four-to 3)]
|
|
||||||
|
|
||||||
@note{In π-calculus encodings of programs, replication and state are
|
|
||||||
made explicit.} Immutable programs (of which stateless programs are a
|
|
||||||
special case) are easily able to be @emph{replicated}; programs using
|
|
||||||
mutable state, however, must be fixed in place. In fact, strictly
|
|
||||||
speaking, it is the @emph{state} that must be fixed in place, not the
|
|
||||||
program @emph{manipulating} the state. In the following program, the
|
|
||||||
mutable @racket[total] variable must not be replicated:
|
|
||||||
|
|
||||||
@interaction[(define accumulate
|
|
||||||
(let ((total 0))
|
|
||||||
(lambda (n)
|
|
||||||
(set! total (+ total n))
|
|
||||||
total)))
|
|
||||||
(accumulate 3)
|
|
||||||
(accumulate 4)
|
|
||||||
(accumulate 0)]
|
|
||||||
|
|
||||||
It would be a mistake to simply replace each occurrence of
|
|
||||||
@racket[accumulate] with its definition, since three separate
|
|
||||||
@racket[total] locations would be created. However, there is no
|
|
||||||
problem replicating the @racket[lambda] term, so long as
|
|
||||||
@racket[total] always refers to the same location:
|
|
||||||
|
|
||||||
@interaction[(define total 0)
|
|
||||||
((lambda (n) (set! total (+ total n)) total) 3)
|
|
||||||
((lambda (n) (set! total (+ total n)) total) 4)
|
|
||||||
((lambda (n) (set! total (+ total n)) total) 0)]
|
|
||||||
|
|
||||||
Programs raise exceptions to signal partial failure:
|
|
||||||
|
|
||||||
@interaction[(define accumulate
|
|
||||||
(let ((total 0))
|
|
||||||
(lambda (n)
|
|
||||||
(when (negative? n)
|
|
||||||
(error 'accumulate "n must be non-negative!"))
|
|
||||||
(set! total (+ total n))
|
|
||||||
total)))
|
|
||||||
(accumulate 3)
|
|
||||||
(accumulate -2)]
|
|
||||||
|
|
||||||
Programs can handle exceptions to @emph{contain} partial failure:
|
|
||||||
|
|
||||||
@interaction[(with-handlers ([exn:fail? (lambda (e) 'ok)])
|
|
||||||
(error 'oh-dear))]
|
|
||||||
|
|
||||||
Partial failures interact with shared, mutable state in unpredictable
|
|
||||||
ways, especially in larger programs that combine stateful subprograms.
|
|
||||||
|
|
||||||
@note{For a good overview of PL-based approaches to security and
|
|
||||||
trust, see Mark S. Miller's
|
|
||||||
"@hyperlink["http://www.erights.org/talks/thesis/markm-thesis.pdf"]{Robust
|
|
||||||
composition: Towards a unified approach to access control and
|
|
||||||
concurrency control}" and Jonathan A. Rees's
|
|
||||||
"@hyperlink["http://dspace.mit.edu/bitstream/handle/1721.1/5944/AIM-1564.pdf"]{A
|
|
||||||
Security Kernel Based on the Lambda-Calculus}".} Programmers often
|
|
||||||
ignore issues of security and trust between subprograms within a
|
|
||||||
larger program. Most programming languages entirely lack any means of
|
|
||||||
securely isolating subprograms from each other, leading to predictable
|
|
||||||
failures. Even memory-safe languages such as Racket, Java and .NET
|
|
||||||
only offer weak techniques for securely composing mutually suspicious
|
|
||||||
subprograms. Techniques such as avoiding @emph{ambient authority} and
|
|
||||||
using @emph{object capabilities} to compose subprograms
|
|
||||||
|
|
||||||
TODO ^
|
|
||||||
|
|
||||||
@section{Network programming in the large}
|
|
||||||
|
|
||||||
Programs which engage in I/O are very obviously part of a network:
|
|
||||||
|
|
||||||
@racketblock[(define (greet-user)
|
|
||||||
(define username (read-line))
|
|
||||||
(define greeting (format "Hello, ~a!\n" username))
|
|
||||||
(display greeting)
|
|
||||||
(newline))
|
|
||||||
(greet-user)]
|
|
||||||
|
|
||||||
Here, the network has two components: the program, and the user at the
|
|
||||||
terminal.
|
|
||||||
|
|
||||||
But look closely! There is a difference here between the kind of
|
|
||||||
communication between this program and its @emph{peer} and the
|
|
||||||
communication @emph{internal} to the program itself. Portions of the
|
|
||||||
program relay information from the outside world, translating it to
|
|
||||||
and from an internal representation as they go, while other portions
|
|
||||||
perform computations on the relayed information.
|
|
||||||
|
|
||||||
@vm-figure[(vm (vm-label "Operating System")
|
|
||||||
(network-label "")
|
|
||||||
(process "User")
|
|
||||||
(process-space)
|
|
||||||
(vm (vm-label "Program")
|
|
||||||
(network-label "")
|
|
||||||
(process "Read line")
|
|
||||||
(process "Format greeting")
|
|
||||||
(process "Print greeting")))]
|
|
|
@ -1,254 +0,0 @@
|
||||||
#lang scribble/manual
|
|
||||||
@require[racket/include]
|
|
||||||
@include{prelude.inc}
|
|
||||||
|
|
||||||
@title{Concepts}
|
|
||||||
|
|
||||||
Marketplace integrates ideas from both distributed systems and
|
|
||||||
virtualized operating system designs to obtain an architecture of
|
|
||||||
nested @emph{virtual machines} (VMs). Each nested layer is equipped
|
|
||||||
with its own publish/subscribe network that also propagates
|
|
||||||
@emph{presence} information about the (dis)appearance of services.
|
|
||||||
|
|
||||||
Throughout this manual, diagrams such as the following will illustrate
|
|
||||||
various process structures:
|
|
||||||
|
|
||||||
@vm-figure[(vm (vm-label "Ground Virtual Machine")
|
|
||||||
(network-label "Ground-level Network Language")
|
|
||||||
(process "A Process")
|
|
||||||
(process "Another Process")
|
|
||||||
(parameterize ((process-height (* 2/3 (process-height)))
|
|
||||||
(vm-height (* 2 (vm-height))))
|
|
||||||
(vm (vc-append (vm-label "Nested VMs are")
|
|
||||||
(vm-label "processes too"))
|
|
||||||
(network-label "App-specific language")
|
|
||||||
(process "Process")
|
|
||||||
(process "Process")
|
|
||||||
(process "Process")))
|
|
||||||
(parameterize ((process-height (* 5/4 (process-height))))
|
|
||||||
(process "Yet another process"))
|
|
||||||
(parameterize ((process-height (* 2/3 (process-height))))
|
|
||||||
(vm (vm-label "Another Nested VM")
|
|
||||||
(network-label "Another language")
|
|
||||||
(process "Process")
|
|
||||||
(process "Process"))))]
|
|
||||||
|
|
||||||
Rectangular boxes represent VMs. The processes running within each VM
|
|
||||||
are placed atop its box. The narrow rectangular strip at the top of
|
|
||||||
each VM's box represents the network connecting all the VM's processes
|
|
||||||
to each other; it will frequently contain a short description of the
|
|
||||||
protocols used for communication across the represented network.
|
|
||||||
|
|
||||||
A central feature of Marketplace is that VMs are nothing more than
|
|
||||||
regular processes, making them recursively nestable. Each VM supports
|
|
||||||
a collection of processes all its own, and its internal IPC medium
|
|
||||||
carries a VM-specific protocol that is often different from the
|
|
||||||
protocol spoken by its containing VM.
|
|
||||||
|
|
||||||
The outermost VM is called the @emph{ground VM}. The protocol spoken
|
|
||||||
by processes running within the ground VM is a simple protocol
|
|
||||||
relating Racket's @tech{synchronizable events} to Marketplace network
|
|
||||||
messages. See @;{@secref{writing-new-drivers} and} @secref{Drivers} for
|
|
||||||
information on using Racket events from Marketplace programs.
|
|
||||||
|
|
||||||
@section{What is a process, what are event handlers?}
|
|
||||||
|
|
||||||
A Marketplace @deftech{process} is a collection of @deftech{event
|
|
||||||
handlers}, plus a piece of private @deftech{process state}. Every
|
|
||||||
process@note{The exception to this rule is the Ground VM, which plays
|
|
||||||
a special role.} runs within a containing VM.
|
|
||||||
|
|
||||||
When an event occurs that is relevant to a process, one of its event
|
|
||||||
handlers is called with the process's current state and a description
|
|
||||||
of the event. The handler is expected to return an updated state value
|
|
||||||
and a collection of actions for the containing VM to perform. An event
|
|
||||||
handler, then, has the following approximate type:
|
|
||||||
|
|
||||||
@centered{@italic{State} × @italic{Event} → @italic{State} × (Listof @italic{Action})}
|
|
||||||
|
|
||||||
Event handlers are registered with the VM by creating @tech{endpoints}
|
|
||||||
using the @racket[endpoint] macro (described in @secref{endpoint-dsl}) or
|
|
||||||
the low-level @racket[add-endpoint] structure (described in
|
|
||||||
@secref{endpoints-and-messages}).
|
|
||||||
|
|
||||||
@deftech{Events}, passed to event handlers, describe the results of
|
|
||||||
actions from the outside world, neighbouring processes in the VM, or
|
|
||||||
the VM itself. They are implemented as @racket[struct]s. See
|
|
||||||
@secref{endpoint-events} for a description of the available event
|
|
||||||
structures.
|
|
||||||
|
|
||||||
@deftech{Actions}, passed back to the VM by event handlers, describe
|
|
||||||
actions the process wishes to perform. See @secref{Actions} for the
|
|
||||||
possible actions a process can take.
|
|
||||||
|
|
||||||
Note that the result of an event handler function is actually a
|
|
||||||
@racket[transition] structure containing a new state and a sequence of
|
|
||||||
actions, rather than the explicit pair shown in the approximate type
|
|
||||||
above. See @secref{handler-functions} for more on handler functions.
|
|
||||||
|
|
||||||
@section{What is a VM?}
|
|
||||||
|
|
||||||
@deftech[#:key "vm"]{Virtual Machines (VMs)} are simply a collection
|
|
||||||
of processes, plus a shared medium of communication that the contained
|
|
||||||
processes use to communicate with each other. VMs offer access to both
|
|
||||||
their own @emph{internal} network as well as to the @emph{external}
|
|
||||||
network owned by the VM's own containing VM.@note{Again, the only
|
|
||||||
exception here is the Ground VM, which interfaces to the underlying
|
|
||||||
Racket system and so has no containing VM.}
|
|
||||||
|
|
||||||
@section{Endpoints: Subscription and Advertisement}
|
|
||||||
|
|
||||||
The Marketplace operating system's inter-process communication
|
|
||||||
facility is structured around @deftech[#:key
|
|
||||||
"pub/sub"]{publish/subscribe (pub/sub)} messaging.@note{For a survey
|
|
||||||
of pub/sub messaging, see
|
|
||||||
@hyperlink["http://www.cs.ru.nl/~pieter/oss/manyfaces.pdf"]{"The Many
|
|
||||||
Faces of Publish/Subscribe"}, ACM Computing Surveys, Vol. 35, No. 2,
|
|
||||||
June 2003, pp. 114–131. There's also plenty out there on the Internet;
|
|
||||||
a good starting point is to google for
|
|
||||||
@hyperlink["https://www.google.com/search?q=pub/sub message-oriented middleware"]{pub/sub message-oriented middleware}.}
|
|
||||||
|
|
||||||
@deftech{Endpoints} are the representation of a process's engagement
|
|
||||||
in some protocol. They pair a description of the process's @tech{role}
|
|
||||||
in a conversation with an @tech{event handler} that responds to events
|
|
||||||
relating to that role.
|
|
||||||
|
|
||||||
A @deftech{role} describes the role some process is playing in a
|
|
||||||
conversation. Concretely, roles are represented by @racket[Role]
|
|
||||||
structures. A role can be used by the currently-running process to
|
|
||||||
describe some role it wishes to play, or can be carried in some
|
|
||||||
@racket[EndpointEvent] to describe the role some @emph{peer} process
|
|
||||||
is playing in a conversation.
|
|
||||||
|
|
||||||
Roles have three parts:
|
|
||||||
|
|
||||||
@itemlist[
|
|
||||||
|
|
||||||
@item{An @deftech{orientation} (type @racket[Orientation]) describes
|
|
||||||
whether this role is concerned primarily with @emph{producing} or
|
|
||||||
@emph{consuming} messages.}
|
|
||||||
|
|
||||||
@item{A @deftech{topic} is a @deftech{pattern} over messages. Topics
|
|
||||||
perform double duty: they both scope conversations and filter
|
|
||||||
incoming messages. More on topics below.}
|
|
||||||
|
|
||||||
@item{An @deftech{interest-type} (type @racket[InterestType])
|
|
||||||
determines whether the endpoint playing the given role is genuinely
|
|
||||||
a participant in matching conversations or is simply observing the
|
|
||||||
real participants. See @secref{endpoint-dsl} for more on
|
|
||||||
interest-types.}
|
|
||||||
|
|
||||||
]
|
|
||||||
|
|
||||||
@section[#:tag "messages-and-topics"]{Messages and Topics}
|
|
||||||
|
|
||||||
@declare-exporting[marketplace]
|
|
||||||
|
|
||||||
@deftech{Messages} are simply Racket data structures. They can be any
|
|
||||||
value for which @racket[equal?] is defined, any @racket[#:prefab]
|
|
||||||
structure, most @racket[#:transparent] structures, or any non-object
|
|
||||||
structure for which @racket[prop:struct-map] can be defined.
|
|
||||||
|
|
||||||
As mentioned above, topics are simply patterns over messages. They are
|
|
||||||
represented as normal data structures @emph{with embedded wildcards}.
|
|
||||||
Use @racket[?] or @racket[(wild)] to construct a wildcard. For
|
|
||||||
example, given the following definition,
|
|
||||||
|
|
||||||
@racketblock[(struct chat-message (speaker text) #:transparent)]
|
|
||||||
|
|
||||||
we can not only create instances that might be used with
|
|
||||||
@racket[send-message],
|
|
||||||
|
|
||||||
@racketblock[(chat-message "Tony" "Hello World!")]
|
|
||||||
|
|
||||||
but also create topic patterns using @racket[?]. For example, this
|
|
||||||
pattern matches anything said by @racket["Tony"]:
|
|
||||||
|
|
||||||
@racketblock[(chat-message "Tony" ?)]
|
|
||||||
|
|
||||||
This pattern matches chat-messages sent by anyone saying "Hello":
|
|
||||||
|
|
||||||
@racketblock[(chat-message ? "Hello")]
|
|
||||||
|
|
||||||
And finally, this pattern matches any chat-message at all:
|
|
||||||
|
|
||||||
@racketblock[(chat-message ? ?)]
|
|
||||||
|
|
||||||
Patterns can be nested. For instance, given the above definition of
|
|
||||||
@racket[chat-message], the following pattern matches any chat message
|
|
||||||
greeting anybody at all:
|
|
||||||
|
|
||||||
@racketblock[(struct greeting (target) #:transparent)
|
|
||||||
(chat-message ? (greeting ?))]
|
|
||||||
|
|
||||||
@section{Presence}
|
|
||||||
|
|
||||||
@deftech{Presence} (respectively its opposite, @deftech{absence}) is
|
|
||||||
an indication that a matching conversational partner exists (resp. no
|
|
||||||
longer exists) in the network. Presence can be used to synchronize
|
|
||||||
conversations, setting up a conversational context before messages are
|
|
||||||
sent.
|
|
||||||
|
|
||||||
The term "presence" itself is lifted from Instant Messaging protocols
|
|
||||||
like XMPP, where it describes the online/offline status of one's chat
|
|
||||||
buddies. Here, it describes the online/offline status of peer
|
|
||||||
processes, in terms of which conversations they are willing to engage
|
|
||||||
in.
|
|
||||||
|
|
||||||
The system derives presence information from the set of active pub/sub
|
|
||||||
subscription and advertisement endpoints a process has created.
|
|
||||||
Creating a new endpoint with a topic pattern that matches some other
|
|
||||||
process's endpoint and an orientation @emph{opposite} to the other
|
|
||||||
process's endpoint causes @racket[presence-event]s to be sent to both
|
|
||||||
endpoints, informing them of the presence of the other. When a process
|
|
||||||
crashes, or an endpoint is withdrawn with @racket[delete-endpoint], a
|
|
||||||
corresponding @racket[absence-event] is sent to the remaining
|
|
||||||
endpoint.
|
|
||||||
|
|
||||||
@section{Nesting, relaying, and levels of discourse}
|
|
||||||
|
|
||||||
Because VMs can be nested, and each VM has an IPC network of its own
|
|
||||||
for the use of its processes, information sometimes needs to be
|
|
||||||
relayed from a VM's external network to its internal network and vice
|
|
||||||
versa.
|
|
||||||
|
|
||||||
In general, the protocol messages sent across a VM's internal network
|
|
||||||
may be quite different in syntax and meaning from those sent across
|
|
||||||
the same VM's external network: consider the case of the
|
|
||||||
@secref{chat-server-example}, which employs a nested VM to separate
|
|
||||||
out TCP-related messages from higher-level, application-specific chat
|
|
||||||
messages:
|
|
||||||
|
|
||||||
@vm-figure[(vm (vm-label "Ground VM")
|
|
||||||
(network-label "TCP")
|
|
||||||
(process "TCP driver")
|
|
||||||
(process "TCP listener")
|
|
||||||
(process-space)
|
|
||||||
(process "TCP socket mgr.")
|
|
||||||
(process "TCP socket mgr.")
|
|
||||||
(process-ellipsis)
|
|
||||||
(process-space)
|
|
||||||
(vm (vm-label "Nested VM")
|
|
||||||
(network-label "(X says Y)")
|
|
||||||
(process "Listener")
|
|
||||||
(process-space)
|
|
||||||
(process "Chat session")
|
|
||||||
(process "Chat session")
|
|
||||||
(process-ellipsis)))]
|
|
||||||
|
|
||||||
Each VM's network corresponds to a distinct @emph{level of discourse}.
|
|
||||||
The nesting of VMs is then roughly analogous to the layering of
|
|
||||||
network protocol stacks. For example (and purely hypothetically!) the
|
|
||||||
TCP-IP/HTTP/Webapp stack could perhaps be represented as
|
|
||||||
|
|
||||||
@vm-figure[(vm (vm-label "Ground VM")
|
|
||||||
(network-label "TCP/IP")
|
|
||||||
(process "TCP driver")
|
|
||||||
(vm (vm-label "HTTP VM")
|
|
||||||
(network-label "HTTP sessions/reqs/reps")
|
|
||||||
(process "HTTP accepter")
|
|
||||||
(vm (vm-label "Session VM")
|
|
||||||
(network-label "Session-specific msgs")
|
|
||||||
(process "App process")
|
|
||||||
(process-ellipsis))
|
|
||||||
(process-ellipsis)))]
|
|
|
@ -1,209 +0,0 @@
|
||||||
#lang scribble/manual
|
|
||||||
@require[racket/include]
|
|
||||||
@include{prelude.inc}
|
|
||||||
|
|
||||||
@require[(for-label marketplace/drivers/event-relay
|
|
||||||
marketplace/drivers/tcp-bare)]
|
|
||||||
|
|
||||||
@title{Drivers}
|
|
||||||
|
|
||||||
@section{event-relay}
|
|
||||||
|
|
||||||
@defmodule[marketplace/drivers/event-relay]{
|
|
||||||
|
|
||||||
@defproc[(event-relay [self-id Symbol]) Spawn]{
|
|
||||||
|
|
||||||
Lets processes in some nested VM interact with the outside
|
|
||||||
world using @racket[ground-vm]-level event-based subscriptions.
|
|
||||||
|
|
||||||
Returns a @racket[spawn] which starts an event-relay process with
|
|
||||||
debug-name @racket[`(event-relay ,self-id)].
|
|
||||||
|
|
||||||
The relay process observes subscriptions matching the topic-pattern
|
|
||||||
@racket[(cons (? evt?) _)], and when one appears, constructs an
|
|
||||||
analogous one using @racket[at-meta-level] to connect to the next VM
|
|
||||||
down the stack. Messages from the meta-level will be relayed up to the
|
|
||||||
current level. When the subscription disappears, the relay withdraws
|
|
||||||
the subscription at the meta-level as well.
|
|
||||||
|
|
||||||
}
|
|
||||||
|
|
||||||
}
|
|
||||||
|
|
||||||
@section{tcp-bare}
|
|
||||||
|
|
||||||
@defmodule[marketplace/drivers/tcp-bare]{
|
|
||||||
|
|
||||||
This module is included by default in programs using @tt{#lang
|
|
||||||
marketplace}; see @secref{hashlang-variations} for information on
|
|
||||||
other language variants.
|
|
||||||
|
|
||||||
@defproc[(tcp-driver) Spawn]{
|
|
||||||
|
|
||||||
Returns a @racket[spawn] action which starts a TCP driver. The TCP
|
|
||||||
driver should run either directly in a ground VM, or in a nested VM
|
|
||||||
with a running @racket[event-relay].
|
|
||||||
|
|
||||||
}
|
|
||||||
|
|
||||||
@defthing[tcp Spawn]{
|
|
||||||
|
|
||||||
A pre-made @racket[spawn] action equivalent to @racket[(tcp-driver)].
|
|
||||||
|
|
||||||
}
|
|
||||||
|
|
||||||
}
|
|
||||||
|
|
||||||
@subsection{TCP channels}
|
|
||||||
|
|
||||||
@defstruct*[tcp-channel ([source (or/c tcp-address? tcp-handle? tcp-listener?)]
|
|
||||||
[destination (or/c tcp-address? tcp-handle? tcp-listener?)]
|
|
||||||
[subpacket (or/c eof-object? bytes?)]) #:prefab]{
|
|
||||||
|
|
||||||
A TCP channel represents a section of a unidirectional TCP flow
|
|
||||||
appearing on our local "subnet" of the full TCP network, complete with
|
|
||||||
source, destination and subpacket. Each TCP connection has two such
|
|
||||||
flows: one inbound (remote-to-local) bytestream, and one outbound
|
|
||||||
(local-to-remote) bytestream.
|
|
||||||
|
|
||||||
Packets carried by @racket[tcp-channel] structures are either
|
|
||||||
end-of-file objects or raw binary data represented as Racket byte
|
|
||||||
vectors.
|
|
||||||
|
|
||||||
}
|
|
||||||
|
|
||||||
@subsection{TCP addresses}
|
|
||||||
|
|
||||||
A TCP address describes one end of a TCP connection. It can be either
|
|
||||||
|
|
||||||
@itemlist[
|
|
||||||
@item{a @racket[tcp-address], representing a remote socket;}
|
|
||||||
@item{a @racket[tcp-handle], representing a local socket on a kernel-assigned port; or}
|
|
||||||
@item{a @racket[tcp-listener], representing a local socket on a user-assigned port.}
|
|
||||||
]
|
|
||||||
|
|
||||||
@defstruct*[tcp-address ([host string?]
|
|
||||||
[port (integer-in 0 65535)]) #:prefab]{
|
|
||||||
|
|
||||||
Describes a remote half-connection. The @racket[host] part is to be a
|
|
||||||
string containing either a hostname (e.g. @racket["localhost"]) or an
|
|
||||||
ASCII representation of an IP address (e.g. @racket["127.0.0.1"]).
|
|
||||||
|
|
||||||
}
|
|
||||||
|
|
||||||
@defstruct*[tcp-handle ([id any/c]) #:prefab]{
|
|
||||||
|
|
||||||
Describes a local half-connection with a kernel-assigned port number.
|
|
||||||
The port number is not directly accessible; the @racket[id] is used as
|
|
||||||
a local name for whichever underlying port number ends up being used.
|
|
||||||
|
|
||||||
The @racket[id] must be chosen carefully: it is scoped to the local
|
|
||||||
VM, i.e. shared between processes in that VM, so processes must make
|
|
||||||
sure not to accidentally clash in handle ID selection. They are also
|
|
||||||
used in @racket[tcp-channel] to mean a specific @emph{instance} of a TCP
|
|
||||||
connection, so if you are likely to want to reconnect individual
|
|
||||||
flows, use different values for @racket[id].
|
|
||||||
|
|
||||||
}
|
|
||||||
|
|
||||||
@defstruct*[tcp-listener ([port (integer-in 0 65535)]) #:prefab]{
|
|
||||||
|
|
||||||
Describes a local half-connection with a user-assigned port number.
|
|
||||||
Use this to describe server sockets.
|
|
||||||
|
|
||||||
}
|
|
||||||
|
|
||||||
@subsection{Opening an outbound connection}
|
|
||||||
|
|
||||||
Choose a @racket[tcp-handle], and then create endpoints as follows:
|
|
||||||
|
|
||||||
@racketblock[
|
|
||||||
(let ((local (tcp-handle 'some-unique-value))
|
|
||||||
(remote (tcp-address "the.remote.host.example.com" 5999)))
|
|
||||||
(transition/no-state
|
|
||||||
(publisher (tcp-channel local remote ?))
|
|
||||||
(subscriber (tcp-channel remote local ?)
|
|
||||||
(on-message
|
|
||||||
[(tcp-channel _ _ (? eof-object?))
|
|
||||||
(code:comment "Handle a received end-of-file object")
|
|
||||||
(transition ...)]
|
|
||||||
[(tcp-channel _ _ (? bytes? data))
|
|
||||||
(code:comment "Handle received data")
|
|
||||||
(transition ...)]))))
|
|
||||||
]
|
|
||||||
|
|
||||||
The TCP driver will automatically create an outbound connection in
|
|
||||||
response to the presence of the endpoints. When the endpoints are
|
|
||||||
deleted (or the process exits), the TCP driver will notice the absence
|
|
||||||
and will close the underlying TCP socket.
|
|
||||||
|
|
||||||
For a complete example, see @secref{chat-client-example}.
|
|
||||||
|
|
||||||
@subsection{Accepting inbound connections}
|
|
||||||
|
|
||||||
Choose a port number, and then create an @emph{observer} endpoint as
|
|
||||||
follows:
|
|
||||||
|
|
||||||
@racketblock[
|
|
||||||
(observe-publishers (tcp-channel ? (tcp-listener 5999) ?)
|
|
||||||
(match-conversation (tcp-channel them us _)
|
|
||||||
(on-presence (spawn (chat-session them us)))))
|
|
||||||
]
|
|
||||||
|
|
||||||
The use of @racket[observe-publishers] here indicates that this endpoint isn't
|
|
||||||
actually interested in exchanging any TCP data; instead, it is
|
|
||||||
monitoring demand for such exchanges. The TCP driver uses the unusual
|
|
||||||
@racket['everything] @racket[InterestType] to monitor the presence of
|
|
||||||
@racket['observer]s, and creates listening TCP server sockets in
|
|
||||||
response. When a connection comes in, the TCP driver spawns a manager
|
|
||||||
process which offers regular @racket['participant] endpoints for
|
|
||||||
communicating on the newly-arrived socket.
|
|
||||||
|
|
||||||
To illustrate the code for handling a newly-arrived connection,
|
|
||||||
|
|
||||||
@racketblock[
|
|
||||||
(define (chat-session them us)
|
|
||||||
(transition/no-state
|
|
||||||
(subscriber (tcp-channel them us ?)
|
|
||||||
(on-absence (quit))
|
|
||||||
(on-message [(tcp-channel _ _ (? bytes? data))
|
|
||||||
(code:comment "Handle incoming data")
|
|
||||||
(transition ...)]))))
|
|
||||||
]
|
|
||||||
|
|
||||||
@subsection{Receiving data}
|
|
||||||
|
|
||||||
TCP-related messages will be of the form
|
|
||||||
|
|
||||||
@racketblock[(tcp-channel remote-address local-address subpacket)]
|
|
||||||
|
|
||||||
where the @racket[subpacket] is either @racket[eof] or a
|
|
||||||
@racket[bytes?].
|
|
||||||
|
|
||||||
@subsection{Sending data}
|
|
||||||
|
|
||||||
Send data with
|
|
||||||
|
|
||||||
@racketblock[(send-message (tcp-channel local-address remote-address subpacket))]
|
|
||||||
|
|
||||||
where, as for receiving data, the @racket[subpacket] is either
|
|
||||||
@racket[eof] or a @racket[bytes?].
|
|
||||||
|
|
||||||
@;{
|
|
||||||
@section{tcp}
|
|
||||||
Not yet documented.
|
|
||||||
}
|
|
||||||
|
|
||||||
@section{timer}
|
|
||||||
|
|
||||||
For examples of the use of the timer driver, see uses of
|
|
||||||
@racket[set-timer] and @racket[timer-expired] in
|
|
||||||
@hyperlink["https://github.com/tonyg/marketplace-dns/blob/master/network-query.rkt"]{the
|
|
||||||
Marketplace-based DNS resolver}.
|
|
||||||
|
|
||||||
@section{udp}
|
|
||||||
|
|
||||||
For examples of the use of the UDP driver, see uses of
|
|
||||||
@racket[udp-packet] etc. in
|
|
||||||
@hyperlink["https://github.com/tonyg/marketplace-dns/blob/master/tk-dns.rkt"]{the
|
|
||||||
Marketplace-based DNS resolver}.
|
|
|
@ -1,139 +0,0 @@
|
||||||
#lang scribble/manual
|
|
||||||
@require[racket/include]
|
|
||||||
@include{prelude.inc}
|
|
||||||
|
|
||||||
@title{Examples}
|
|
||||||
|
|
||||||
@section[#:tag "echo-server-example"]{TCP echo server}
|
|
||||||
|
|
||||||
Here is a complete Marketplace program:
|
|
||||||
|
|
||||||
@#reader scribble/comment-reader (racketmod #:file "examples/echo-paper.rkt" marketplace
|
|
||||||
|
|
||||||
(observe-publishers (tcp-channel ? (tcp-listener 5999) ?)
|
|
||||||
(match-conversation (tcp-channel from to _)
|
|
||||||
(on-presence (spawn (echoer from to)))))
|
|
||||||
|
|
||||||
(define (echoer from to)
|
|
||||||
(transition stateless
|
|
||||||
(publisher (tcp-channel to from ?))
|
|
||||||
(subscriber (tcp-channel from to ?)
|
|
||||||
(on-absence (quit))
|
|
||||||
(on-message
|
|
||||||
[(tcp-channel _ _ data)
|
|
||||||
(send-message (tcp-channel to from data))]))))
|
|
||||||
)
|
|
||||||
|
|
||||||
The top-level @racket[observe-publishers] monitors TCP connections
|
|
||||||
arriving on port 5999 and @racket[spawn]s a fresh process in response
|
|
||||||
to each with the help of the auxiliary @racket[echoer] function. The
|
|
||||||
topic of conversation associated with the each new connection is
|
|
||||||
parsed (with @racket[match-conversation]) to name the remote
|
|
||||||
(@racket[from]) and local (@racket[to]) TCP addresses, which are
|
|
||||||
passed to @racket[echoer] to create the initial state and actions for
|
|
||||||
the corresponding process. In this case, the process is stateless,
|
|
||||||
indicated by the special constant @racket[stateless].
|
|
||||||
|
|
||||||
Each connection's process watches for incoming data, using
|
|
||||||
@racket[from] and @racket[to] to configure a @racket[subscriber]. It
|
|
||||||
also declares its intent to produce outbound TCP data, using
|
|
||||||
@racket[publisher]. When data arrives, it is echoed back to the remote
|
|
||||||
peer using the @racket[send-message] operation. Absence notifications
|
|
||||||
signal disconnection; when the remote peer closes the TCP connection,
|
|
||||||
the @racket[on-absence] handler issues a @racket[quit] action, which
|
|
||||||
terminates the connection's process.
|
|
||||||
|
|
||||||
@section[#:tag "chat-server-example"]{TCP chat server}
|
|
||||||
|
|
||||||
@#reader scribble/comment-reader (racketmod #:file "examples/chat-paper.rkt" marketplace
|
|
||||||
|
|
||||||
(spawn-vm
|
|
||||||
(at-meta-level
|
|
||||||
(observe-publishers (tcp-channel ? (tcp-listener 5999) ?)
|
|
||||||
(match-conversation (tcp-channel them us _)
|
|
||||||
(on-presence (spawn (chat-session them us)))))))
|
|
||||||
|
|
||||||
(define (chat-session them us)
|
|
||||||
(define user (gensym 'user))
|
|
||||||
(transition stateless
|
|
||||||
(listen-to-user user them us)
|
|
||||||
(speak-to-user user them us)))
|
|
||||||
|
|
||||||
(define (listen-to-user user them us)
|
|
||||||
(list
|
|
||||||
(at-meta-level
|
|
||||||
(subscriber (tcp-channel them us ?)
|
|
||||||
(on-absence (quit))
|
|
||||||
(on-message
|
|
||||||
[(tcp-channel _ _ (? bytes? text))
|
|
||||||
(send-message `(,user says ,text))])))
|
|
||||||
(publisher `(,user says ,?))))
|
|
||||||
|
|
||||||
(define (speak-to-user user them us)
|
|
||||||
(define (say fmt . args)
|
|
||||||
(at-meta-level
|
|
||||||
(send-message
|
|
||||||
(tcp-channel us them (apply format fmt args)))))
|
|
||||||
(define (announce who did-what)
|
|
||||||
(unless (equal? who user)
|
|
||||||
(say "~s ~s.~n" who did-what)))
|
|
||||||
(list
|
|
||||||
(say "You are ~s.~n" user)
|
|
||||||
(at-meta-level
|
|
||||||
(publisher (tcp-channel us them ?)))
|
|
||||||
(subscriber `(,? says ,?)
|
|
||||||
(match-conversation `(,who says ,_)
|
|
||||||
(on-presence (announce who 'arrived))
|
|
||||||
(on-absence (announce who 'departed))
|
|
||||||
(on-message [`(,who says ,what)
|
|
||||||
(say "~a: ~a" who what)])))))
|
|
||||||
)
|
|
||||||
|
|
||||||
@section[#:tag "chat-client-example"]{TCP chat client}
|
|
||||||
|
|
||||||
@#reader scribble/comment-reader (racketmod #:file "examples/chat-client.rkt" marketplace
|
|
||||||
(require racket/port)
|
|
||||||
|
|
||||||
;; Usually it's OK to just use display and friends directly.
|
|
||||||
;; Here we have a console output driver just to show how it's done.
|
|
||||||
(name-process 'console-output-driver
|
|
||||||
(spawn (transition/no-state
|
|
||||||
(subscriber (list 'console-output ?)
|
|
||||||
(on-message [(list 'console-output item)
|
|
||||||
(printf "~a" item)
|
|
||||||
(void)])))))
|
|
||||||
|
|
||||||
(name-process 'console-input-driver
|
|
||||||
(spawn (transition/no-state
|
|
||||||
(name-endpoint 'input-relay
|
|
||||||
(publisher (list 'console-input ?)
|
|
||||||
(on-absence
|
|
||||||
(send-message (list 'console-output "Connection terminated.\n"))
|
|
||||||
(quit))))
|
|
||||||
(subscriber (cons (read-line-evt (current-input-port) 'any) ?)
|
|
||||||
(on-message
|
|
||||||
[(cons _ (? eof-object?))
|
|
||||||
(send-message (list 'console-output "Terminating on local EOF.\n"))
|
|
||||||
(delete-endpoint 'input-relay)]
|
|
||||||
[(cons _ (? string? line))
|
|
||||||
(send-message (list 'console-input line))])))))
|
|
||||||
|
|
||||||
(name-process 'outbound-connection
|
|
||||||
(spawn (let ((local (tcp-handle 'outbound))
|
|
||||||
(remote (tcp-address "localhost" 5999)))
|
|
||||||
(transition/no-state
|
|
||||||
(subscriber (list 'console-input ?)
|
|
||||||
(on-absence (quit))
|
|
||||||
(on-message
|
|
||||||
[(list 'console-input line)
|
|
||||||
(send-message (list 'console-output (format "> ~a \n" line)))
|
|
||||||
(send-message (tcp-channel local remote (string-append line "\n")))]))
|
|
||||||
(publisher (tcp-channel local remote ?))
|
|
||||||
(subscriber (tcp-channel remote local ?)
|
|
||||||
(on-absence (quit))
|
|
||||||
(on-message
|
|
||||||
[(tcp-channel _ _ (? eof-object?))
|
|
||||||
(quit)]
|
|
||||||
[(tcp-channel _ _ data)
|
|
||||||
(send-message (list 'console-output (format "< ~a" data)))]))))))
|
|
||||||
)
|
|
|
@ -1,12 +0,0 @@
|
||||||
#lang racket/base
|
|
||||||
;; Provides |from|, useful for importing identifiers from non-default
|
|
||||||
;; contexts without spelling them differently.
|
|
||||||
|
|
||||||
(require scribble/decode)
|
|
||||||
|
|
||||||
(provide from)
|
|
||||||
|
|
||||||
(define-syntax-rule (from require-spec pre-content ...)
|
|
||||||
(let ()
|
|
||||||
(local-require require-spec)
|
|
||||||
(splice (list pre-content ...))))
|
|
|
@ -1,677 +0,0 @@
|
||||||
#lang scribble/manual
|
|
||||||
@require[racket/include]
|
|
||||||
@include{prelude.inc}
|
|
||||||
|
|
||||||
@title[#:tag "high-level-interface"]{High-level interface}
|
|
||||||
|
|
||||||
@declare-exporting[#:use-sources (marketplace/sugar)]
|
|
||||||
|
|
||||||
This high-level interface between a VM and a process is analogous to
|
|
||||||
the @emph{C library interface} of a Unix-like operating system. The
|
|
||||||
@secref{low-level-interface} corresponds to the @emph{system call
|
|
||||||
interface} of a Unix-like operating system.
|
|
||||||
|
|
||||||
@section[#:tag "hashlang-variations"]{Using @tt{#lang marketplace} and friends}
|
|
||||||
|
|
||||||
@;{
|
|
||||||
@defmodulelang*[(marketplace
|
|
||||||
marketplace/flow-control)]
|
|
||||||
}
|
|
||||||
|
|
||||||
@defmodulelang[marketplace]
|
|
||||||
|
|
||||||
Programs written for Marketplace differ from normal Racket modules
|
|
||||||
only in their selection of language. A Racket module written with
|
|
||||||
@tt{#lang marketplace}, such as the echo server in
|
|
||||||
@secref["echo-server-example"], specifies a sequence of definitions
|
|
||||||
and startup @tech{actions} for an application. Typically, initial
|
|
||||||
actions spawn application processes and nested VMs, which in turn
|
|
||||||
subscribe to sources of events from the outside world.
|
|
||||||
|
|
||||||
At present, there's just @tt{#lang marketplace}. In future, there will
|
|
||||||
be languages providing greater support for flow control,
|
|
||||||
responsibility transfer, and other networking concepts.
|
|
||||||
|
|
||||||
@;{
|
|
||||||
@itemlist[
|
|
||||||
|
|
||||||
@item{@racket[marketplace] is for ordinary Racket programs, and uses
|
|
||||||
the @secref{tcp-bare} TCP driver;}
|
|
||||||
|
|
||||||
@item{@racket[marketplace/flow-control] is like
|
|
||||||
@racket[marketplace], but uses the flow-controlled @secref{tcp}
|
|
||||||
driver;}
|
|
||||||
|
|
||||||
]
|
|
||||||
}
|
|
||||||
|
|
||||||
@section{Using Marketplace as a library}
|
|
||||||
|
|
||||||
@defmodule*[(marketplace/sugar)
|
|
||||||
#:use-sources (marketplace/sugar)]
|
|
||||||
|
|
||||||
Instead of using Racket's @tt{#lang} feature, ordinary Racket programs
|
|
||||||
can use Marketplace features by requiring Marketplace modules
|
|
||||||
directly.
|
|
||||||
|
|
||||||
Such programs need to use @racket[ground-vm] to
|
|
||||||
start the ground-level VM explicitly. They also need to explicitly
|
|
||||||
start any drivers they need; for example, the file
|
|
||||||
@filepath{examples/echo-plain.rkt} uses @racket[ground-vm] along with
|
|
||||||
@racket[tcp] and an initial @racket[endpoint] action:
|
|
||||||
|
|
||||||
@racketblock[
|
|
||||||
(ground-vm tcp
|
|
||||||
(subscriber (tcp-channel ? (tcp-listener 5999) ?)
|
|
||||||
(match-conversation (tcp-channel from to _)
|
|
||||||
(on-presence (spawn (echoer from to))))))
|
|
||||||
]
|
|
||||||
|
|
||||||
@defform[(ground-vm maybe-boot-pid-binding maybe-initial-state initial-action ...)
|
|
||||||
#:grammar
|
|
||||||
[(maybe-boot-pid-binding (code:line)
|
|
||||||
(code:line #:boot-pid id))
|
|
||||||
(maybe-initial-state (code:line)
|
|
||||||
(code:line #:initial-state expr))
|
|
||||||
(initial-action expr)]]{
|
|
||||||
|
|
||||||
Starts the ground VM. If @racket[#:boot-pid] is specified, the given
|
|
||||||
identifier is bound within the form to the PID of the @emph{primordial
|
|
||||||
process} that performs the initial actions. If
|
|
||||||
@racket[#:initial-state] is specified, it is used as the initial state
|
|
||||||
for the primordial process; if it is not supplied, the primordial
|
|
||||||
process is given @racket[(void)] as its initial state.
|
|
||||||
|
|
||||||
}
|
|
||||||
|
|
||||||
@section[#:tag "constructing-transitions"]{Constructing transitions}
|
|
||||||
|
|
||||||
@declare-exporting[#:use-sources (marketplace
|
|
||||||
marketplace/sugar)]
|
|
||||||
|
|
||||||
@deftogether[(
|
|
||||||
@defform[(transition new-state action-tree ...)]
|
|
||||||
@defform[(transition/no-state action-tree ...)]
|
|
||||||
)]{
|
|
||||||
|
|
||||||
Each of these forms produces a @racket[transition] structure.
|
|
||||||
|
|
||||||
Each @racket[action-tree] must be an @tech{action tree}.
|
|
||||||
It's fine to include @emph{no} action trees, in which case the
|
|
||||||
transition merely updates the state of the process without taking any
|
|
||||||
actions.
|
|
||||||
|
|
||||||
In the case of @racket[transition/no-state], the value @racket[(void)]
|
|
||||||
is used for the process state. @racket[transition/no-state] is useful
|
|
||||||
for processes that are stateless other than the implicit state of
|
|
||||||
their endpoints.
|
|
||||||
|
|
||||||
}
|
|
||||||
|
|
||||||
@defstruct*[transition ([state State] [actions action-tree?]) #:transparent]{
|
|
||||||
|
|
||||||
A transition structure. The @racket[transition-state] field is the new
|
|
||||||
private state the process will have after the transition is applied,
|
|
||||||
and the @racket[transition-actions] are the actions that will be
|
|
||||||
performed by the VM in order to apply the transition.
|
|
||||||
|
|
||||||
}
|
|
||||||
|
|
||||||
@defproc[(action-tree? [value any/c]) boolean?]{
|
|
||||||
|
|
||||||
Predicate that recognises an @deftech{action tree}. An action tree is
|
|
||||||
either
|
|
||||||
|
|
||||||
@itemlist[
|
|
||||||
@item{@racket['()];}
|
|
||||||
@item{@racket[#f];}
|
|
||||||
@item{@racket[(void)];}
|
|
||||||
@item{a pair of action trees; or}
|
|
||||||
@item{an @tech{action}.}
|
|
||||||
]
|
|
||||||
|
|
||||||
When performing actions, a VM will traverse an action-tree in
|
|
||||||
left-to-right order.
|
|
||||||
|
|
||||||
@racket['()], @racket[(void)], and @racket[#f] may be present in
|
|
||||||
action-trees: when the VM reaches such a value, it ignores it and
|
|
||||||
continues with the next leaf in the tree.
|
|
||||||
|
|
||||||
For example, all of the following are valid action trees which will
|
|
||||||
send messages @racket[1], @racket[2] and @racket[3] in that order:
|
|
||||||
|
|
||||||
@racketblock[(list (send-message 1)
|
|
||||||
(send-message 2)
|
|
||||||
(send-message 3))]
|
|
||||||
|
|
||||||
@racketblock[(list (list (send-message 1))
|
|
||||||
(cons (send-message 2) (cons '() (send-message 3))))]
|
|
||||||
|
|
||||||
@racketblock[(cons (cons (send-message 1)
|
|
||||||
(send-message 2))
|
|
||||||
(list #f #f (send-message 3)))]
|
|
||||||
|
|
||||||
Because @racket[#f] and @racket[(void)] are valid, ignored, members of
|
|
||||||
an action-tree, @racket[and] and @racket[when] can be used to
|
|
||||||
selectively include actions in an action-tree:
|
|
||||||
|
|
||||||
@racketblock[(list (first-action)
|
|
||||||
(when (condition?)
|
|
||||||
(optional-action))
|
|
||||||
(final-action))]
|
|
||||||
|
|
||||||
@racketblock[(list (first-action)
|
|
||||||
(and (condition?)
|
|
||||||
(optional-action))
|
|
||||||
(final-action))]
|
|
||||||
|
|
||||||
Finally, these inert placeholders can be used to represent "no action
|
|
||||||
at all" in a transition:
|
|
||||||
|
|
||||||
@racketblock[(transition new-state) (code:comment "No action-trees at all")
|
|
||||||
(transition new-state '())
|
|
||||||
(transition new-state (void))
|
|
||||||
(transition new-state #f)]
|
|
||||||
|
|
||||||
}
|
|
||||||
|
|
||||||
@defproc[(sequence-actions [initial-transition transition?]
|
|
||||||
[item (or/c action-tree? (any/c -> transition?))]
|
|
||||||
...) transition?]{
|
|
||||||
|
|
||||||
Returns a transition formed from the @racket[initial-transition]
|
|
||||||
extended with new actions, possibly updating its carried state. Each
|
|
||||||
of the supplied @racket[item]s is examined: if it is an
|
|
||||||
@racket[ActionTree], it is appended to the pending transition's
|
|
||||||
actions; if it is a procedure, it is called with the @emph{state} of
|
|
||||||
the pending transition, and is expected to return an updated
|
|
||||||
transition.
|
|
||||||
|
|
||||||
For example,
|
|
||||||
|
|
||||||
@racketblock[(sequence-actions (transition 'x
|
|
||||||
(send-message (list 'message 0)))
|
|
||||||
(send-message (list 'message 1))
|
|
||||||
(send-message (list 'message 2))
|
|
||||||
(lambda (old-state)
|
|
||||||
(transition (cons 'y old-state)
|
|
||||||
(send-message (list 'message 3))))
|
|
||||||
(send-message (list 'message 4)))]
|
|
||||||
|
|
||||||
produces the equivalent of
|
|
||||||
|
|
||||||
@racketblock[(transition (cons 'y 'x)
|
|
||||||
(send-message (list 'message 0))
|
|
||||||
(send-message (list 'message 1))
|
|
||||||
(send-message (list 'message 2))
|
|
||||||
(send-message (list 'message 3))
|
|
||||||
(send-message (list 'message 4)))]
|
|
||||||
|
|
||||||
}
|
|
||||||
|
|
||||||
@section[#:tag "endpoint-dsl"]{Creating endpoints}
|
|
||||||
|
|
||||||
The primitive action that creates new endpoints is
|
|
||||||
@racket[add-endpoint], but because endpoints are the most flexible and
|
|
||||||
complex point of interaction between a process and its VM, a
|
|
||||||
collection of macros helps streamline endpoint setup.
|
|
||||||
|
|
||||||
@deftogether[(
|
|
||||||
@defform[(publisher topic handler ...)]
|
|
||||||
@defform[(subscriber topic handler ...)]
|
|
||||||
@defform[(observe-subscribers topic handler ...)]
|
|
||||||
@defform[(observe-publishers topic handler ...)]
|
|
||||||
@defform[(observe-subscribers/everything topic handler ...)]
|
|
||||||
@defform[(observe-publishers/everything topic handler ...)]
|
|
||||||
@defform[(build-endpoint pre-eid role handler ...)]
|
|
||||||
)]{
|
|
||||||
|
|
||||||
The many variations on the core
|
|
||||||
@racket[build-endpoint] form exist to give
|
|
||||||
good control over @racket[InterestType] in the endpoint under
|
|
||||||
construction;
|
|
||||||
see @secref{participating-vs-observing}.
|
|
||||||
|
|
||||||
Almost everything is optional in an endpoint definition. The only
|
|
||||||
mandatory part is the topic.
|
|
||||||
|
|
||||||
For example, a minimal endpoint subscribing to all messages would be:
|
|
||||||
|
|
||||||
@racketblock[(subscriber ?)]
|
|
||||||
|
|
||||||
A minimal publishing endpoint would be:
|
|
||||||
|
|
||||||
@racketblock[(publisher ?)]
|
|
||||||
|
|
||||||
While topic patterns are ordinary Racket data with embedded @racket[?]
|
|
||||||
wildcards (see @secref{messages-and-topics}), all the other patterns
|
|
||||||
in an endpoint definition are @racket[match]-patterns. In particular
|
|
||||||
note that @racket[?] is a wildcard in a topic pattern, while
|
|
||||||
@racket[_] is a wildcard in a @racket[match]-pattern.
|
|
||||||
|
|
||||||
@subsection{Receiving messages}
|
|
||||||
|
|
||||||
@defform[(on-message [pattern expr ...] ...)]{
|
|
||||||
|
|
||||||
Supply an @racket[on-message] handler clause to an endpoint definition
|
|
||||||
to handle incoming message events (as distinct from presence- or
|
|
||||||
absence-events).
|
|
||||||
|
|
||||||
The following endpoint @emph{subscribes} to all messages, but only
|
|
||||||
@emph{handles} some of them:
|
|
||||||
|
|
||||||
@racketblock[(subscriber ?
|
|
||||||
(on-message
|
|
||||||
['ping (send-message 'pong)]
|
|
||||||
['hello (list (send-message 'goodbye)
|
|
||||||
(quit))]))]
|
|
||||||
|
|
||||||
}
|
|
||||||
|
|
||||||
}
|
|
||||||
|
|
||||||
@subsection{Action-only vs. State updates}
|
|
||||||
|
|
||||||
@defform[(match-state pattern handler ...)]{
|
|
||||||
|
|
||||||
If a group of handlers is wrapped in @racket[match-state], then all
|
|
||||||
the wrapped handlers are expected to return
|
|
||||||
@seclink["constructing-transitions"]{transition structures}.
|
|
||||||
|
|
||||||
If not, however, the handler expressions are expected to return plain
|
|
||||||
@tech{action tree}s.
|
|
||||||
|
|
||||||
This way, simple handlers that do not need to examine the process
|
|
||||||
state, and simply act in response to whichever event triggered them,
|
|
||||||
can be written without the clutter of threading the process state
|
|
||||||
value through the code.
|
|
||||||
|
|
||||||
For example, a simple endpoint could be written either as
|
|
||||||
|
|
||||||
@racketblock[(subscriber 'ping
|
|
||||||
(on-message ['ping (send-message 'pong)]))]
|
|
||||||
|
|
||||||
or, explicitly accessing the endpoint's process's state,
|
|
||||||
|
|
||||||
@racketblock[(subscriber 'ping
|
|
||||||
(match-state old-state
|
|
||||||
(on-message ['ping (transition old-state
|
|
||||||
(send-message 'pong))])))]
|
|
||||||
|
|
||||||
}
|
|
||||||
|
|
||||||
@subsection{Handling presence and absence events}
|
|
||||||
|
|
||||||
@deftogether[(
|
|
||||||
@defform[(on-presence expr ...)]
|
|
||||||
@defform[(on-absence expr ...)]
|
|
||||||
)]{
|
|
||||||
|
|
||||||
Other endpoints (in this or other processes) may have matching topics
|
|
||||||
and complementary orientations to the current endpoint. When such
|
|
||||||
endpoints come and go, presence and absence events are generated in
|
|
||||||
the current endpoint.
|
|
||||||
|
|
||||||
By default, no actions are taken on such events, but
|
|
||||||
@racket[on-presence] and @racket[on-absence] handlers override this
|
|
||||||
behaviour.
|
|
||||||
|
|
||||||
For example, say process A establishes the following endpoint:
|
|
||||||
|
|
||||||
@racketblock[(subscriber 'ping
|
|
||||||
(on-presence (send-message 'pinger-arrived))
|
|
||||||
(on-absence (send-message 'pinger-departed))
|
|
||||||
(on-message ['ping (send-message 'pong)]))]
|
|
||||||
|
|
||||||
Some time later, process B takes the following endpoint-establishing
|
|
||||||
action:
|
|
||||||
|
|
||||||
@racketblock[(let-fresh (ping-endpoint-name pong-waiter-name)
|
|
||||||
(name-endpoint ping-endpoint-name
|
|
||||||
(publisher 'ping
|
|
||||||
(on-presence
|
|
||||||
(list (name-endpoint pong-waiter-name
|
|
||||||
(subscriber 'pong
|
|
||||||
(on-message
|
|
||||||
['pong (list (delete-endpoint ping-endpoint-name)
|
|
||||||
(delete-endpoint pong-waiter-name))])))
|
|
||||||
(send-message 'ping))))))]
|
|
||||||
|
|
||||||
The sequence of events will be:
|
|
||||||
|
|
||||||
@itemlist[
|
|
||||||
|
|
||||||
@item{Process A's @racket[on-presence] handler will run, and the
|
|
||||||
@racket['pinger-arrived] message will be sent. At the same
|
|
||||||
time,@note{In the current implementation, one happens before the
|
|
||||||
other, but it is nondeterministic which is run first.} process B's
|
|
||||||
@racket[on-presence] handler runs, installing a second endpoint
|
|
||||||
and sending the @racket['ping] message.}
|
|
||||||
|
|
||||||
@item{Process A's endpoint receives the @racket['ping] message, and
|
|
||||||
sends the @racket['pong] message.}
|
|
||||||
|
|
||||||
@item{Process B's second endpoint receives the @racket['pong]
|
|
||||||
message, and deletes both of process B's endpoints.}
|
|
||||||
|
|
||||||
@item{The @racket[on-absence] handler in process A runs, sending
|
|
||||||
the @racket['pinger-departed] message.}
|
|
||||||
|
|
||||||
#:style 'ordered]
|
|
||||||
|
|
||||||
One possible trace of messages in the VM containing processes A and B is
|
|
||||||
|
|
||||||
@racketblock['pinger-arrived
|
|
||||||
'ping
|
|
||||||
'pong
|
|
||||||
'pinger-departed]
|
|
||||||
|
|
||||||
By sending the @racket['ping] message @emph{only} once the
|
|
||||||
@racket[on-presence] handler has fired, process B ensures that
|
|
||||||
someone is listening for pings.
|
|
||||||
|
|
||||||
This way, if process B starts before process A, then B will
|
|
||||||
automatically wait until A is ready to receive ping requests before
|
|
||||||
issuing any.
|
|
||||||
|
|
||||||
}
|
|
||||||
|
|
||||||
@subsection{Exit reasons}
|
|
||||||
|
|
||||||
@defform[(match-reason pattern handler ...)]{
|
|
||||||
|
|
||||||
If a handler is wrapped in a @racket[match-reason] form, then the exit
|
|
||||||
reason supplied to the @racket[delete-endpoint] or @racket[quit]
|
|
||||||
action that led to the @racket[absence-event] is available to the
|
|
||||||
endpoint's @racket[on-absence] handler expression.
|
|
||||||
|
|
||||||
}
|
|
||||||
|
|
||||||
@subsection[#:tag "updating-endpoints"]{Updating endpoints}
|
|
||||||
|
|
||||||
If, when an endpoint is created, an existing endpoint with an
|
|
||||||
@racket[equal?] name is already present, then if the existing and
|
|
||||||
to-be-added endpoints have exactly equal roles (meaning equal
|
|
||||||
orientations, interest-types, and topic patterns), the @emph{handlers}
|
|
||||||
for the endpoint are @emph{updated} without emitting presence or
|
|
||||||
absence notifications.
|
|
||||||
|
|
||||||
This dubious feature can be used to avoid "glitching" of presence
|
|
||||||
signals. A future release of this library will include better
|
|
||||||
automatic support for avoiding such transients.
|
|
||||||
|
|
||||||
@subsection{Who am I talking to?}
|
|
||||||
|
|
||||||
@deftogether[(
|
|
||||||
@defform[(match-orientation pattern handler ...)]
|
|
||||||
@defform[(match-conversation pattern handler ...)]
|
|
||||||
@defform[(match-interest-type pattern handler ...)]
|
|
||||||
)]{
|
|
||||||
|
|
||||||
Wrapping a handler in @racket[match-orientation],
|
|
||||||
@racket[match-conversation], and/or @racket[match-interest-type] gives
|
|
||||||
a handler access to the contents of the @racket[role] structure
|
|
||||||
carried in the triggering @racket[EndpointEvent].
|
|
||||||
|
|
||||||
The carried role describes the @emph{intersection of interests}
|
|
||||||
between the current endpoint and the peer endpoint, and so can proxy
|
|
||||||
for the identity of the other party. It is in a sense a description of
|
|
||||||
the scope of the current conversation.
|
|
||||||
|
|
||||||
It is most common to simply use @racket[match-conversation] to extract
|
|
||||||
the @racket[role-topic] alone, since it is seldom necessary to examine
|
|
||||||
@racket[role-orientation] (since it's guaranteed to be complementary
|
|
||||||
to the orientation of the current endpoint) or
|
|
||||||
@racket[role-interest-type].
|
|
||||||
|
|
||||||
See @secref{Examples} for examples of the use of
|
|
||||||
@racket[match-conversation] and friends.
|
|
||||||
|
|
||||||
}
|
|
||||||
|
|
||||||
@subsection[#:tag "participating-vs-observing"]{Participating in a conversation vs. observing conversations}
|
|
||||||
|
|
||||||
The core @racket[build-endpoint] form takes an expression evaluating
|
|
||||||
to a @racket[role], rather than a simple topic. This gives full
|
|
||||||
control over the new endpoint's @racket[Orientation] and
|
|
||||||
@racket[InterestType].
|
|
||||||
|
|
||||||
The other forms exist for convenience, since usually the orientation
|
|
||||||
and interest-type is known statically, and only the topic varies
|
|
||||||
dynamically:
|
|
||||||
|
|
||||||
@itemlist[
|
|
||||||
|
|
||||||
@item{@racket[publisher] and @racket[subscriber] are for ordinary
|
|
||||||
@emph{participation} in conversations;}
|
|
||||||
|
|
||||||
@item{@racket[observe-subscribers] and @racket[observe-publishers]
|
|
||||||
are for @emph{observing} conversations without participating in them; and}
|
|
||||||
|
|
||||||
@item{@racket[observe-subscribers/everything] and
|
|
||||||
@racket[observe-publishers/everything] are like the ordinary
|
|
||||||
@tt{observe-...} variants, but use interest-type @racket['everything]
|
|
||||||
instead of @racket['observer].}
|
|
||||||
|
|
||||||
]
|
|
||||||
|
|
||||||
The @racket[publisher], @racket[observe-subscribers] and
|
|
||||||
@racket[observe-subscribers/everything] forms create
|
|
||||||
@emph{publisher}-oriented endpoints, and @racket[subscriber],
|
|
||||||
@racket[observe-publishers] and @racket[observe-publishers/everything]
|
|
||||||
create @emph{subscriber}-oriented endpoints. The rationale for this is
|
|
||||||
that as a participant, the code should declare the role being played;
|
|
||||||
but as an observer, the code should declare the roles being observed.
|
|
||||||
|
|
||||||
@subsection[#:tag "naming-endpoints"]{Naming endpoints}
|
|
||||||
|
|
||||||
Endpoint names can be used to @seclink["updating-endpoints"]{update}
|
|
||||||
or @seclink["deleting-endpoints"]{delete} endpoints.
|
|
||||||
|
|
||||||
@defproc[(name-endpoint [id any/c] [add-endpoint-action AddEndpoint]) AddEndpoint]{
|
|
||||||
|
|
||||||
Returns a copy of the passed-in @racket[add-endpoint] action
|
|
||||||
structure, with the @racket[id] field set to the passed-in identifying
|
|
||||||
value.
|
|
||||||
|
|
||||||
}
|
|
||||||
|
|
||||||
@defform[(let-fresh (identifier ...) expr ...)]{
|
|
||||||
|
|
||||||
Binds the @racket[identifier]s to freshly-gensymmed symbols so that
|
|
||||||
they are available to the @racket[exprs]. @racket[let-fresh] is useful
|
|
||||||
for inventing a guaranteed-unused name for a temporary endpoint:
|
|
||||||
|
|
||||||
@racketblock[(let-fresh (my-name)
|
|
||||||
(name-endpoint my-name
|
|
||||||
(subscriber ?
|
|
||||||
(on-message [_ (list (delete-endpoint my-name)
|
|
||||||
...)]))))]
|
|
||||||
|
|
||||||
}
|
|
||||||
|
|
||||||
@section[#:tag "deleting-endpoints"]{Deleting endpoints}
|
|
||||||
|
|
||||||
@defproc[(delete-endpoint [id Any] [reason Any #f]) Action]{
|
|
||||||
|
|
||||||
Use this action to delete a previously-added endpoint by name. The
|
|
||||||
@racket[id] given must be @racket[equal?] to the corresponding
|
|
||||||
@racket[add-endpoint-pre-eid]; when @racket[endpoint] was used to
|
|
||||||
construct the endpoint to be deleted, the relevant name is that bound
|
|
||||||
by @racket[#:let-name] or supplied to @racket[#:name]. See
|
|
||||||
@secref{naming-endpoints}.
|
|
||||||
|
|
||||||
If @racket[reason] is supplied, it is included in the corresponding
|
|
||||||
action, and made available in any resulting @racket[absence-event]s.
|
|
||||||
|
|
||||||
}
|
|
||||||
|
|
||||||
@section{Sending messages and feedback}
|
|
||||||
|
|
||||||
@defproc[(send-message [body Any] [orientation Orientation 'publisher]) Action]{
|
|
||||||
|
|
||||||
Constructs a message-sending action with the given orientation.
|
|
||||||
Usually the correct orientation to use is @racket['publisher]; it
|
|
||||||
means that the sender of the message is acting in the "publisher"
|
|
||||||
role. Use @racket['subscriber] instead when acting in the "subscriber"
|
|
||||||
role, i.e. sending feedback.
|
|
||||||
|
|
||||||
}
|
|
||||||
|
|
||||||
@defproc[(send-feedback [body Any]) Action]{
|
|
||||||
|
|
||||||
Equivalent to @racket[(send-message body 'subscriber)].
|
|
||||||
|
|
||||||
}
|
|
||||||
|
|
||||||
@section{Creating processes}
|
|
||||||
|
|
||||||
@deftogether[(
|
|
||||||
@defform[(spawn maybe-pid-binding boot-expr)]
|
|
||||||
@defform[(spawn/continue maybe-pid-binding
|
|
||||||
#:parent parent-state-pattern k-expr
|
|
||||||
#:child boot-expr)
|
|
||||||
#:grammar
|
|
||||||
[(maybe-pid-binding (code:line)
|
|
||||||
(code:line #:pid identifier))
|
|
||||||
(k-expr expr)
|
|
||||||
(boot-expr expr)]]
|
|
||||||
)]{
|
|
||||||
|
|
||||||
Action describing a new process to create. The @racket[boot-expr]
|
|
||||||
should be an expression yielding a @racket[transition] that contains
|
|
||||||
the child process's initial state and initial actions.
|
|
||||||
|
|
||||||
If @racket[#:pid] is supplied, the associated identifier is bound to
|
|
||||||
the child process's PID in both @racket[boot-expr] and the parent's
|
|
||||||
@racket[k-expr].
|
|
||||||
|
|
||||||
The @racket[spawn/continue] variation includes a @racket[k-expr],
|
|
||||||
which will run in the parent process after the child process has been
|
|
||||||
created. Note that @racket[k-expr] must return a @racket[transition],
|
|
||||||
since @racket[parent-state-pattern] is always supplied for these
|
|
||||||
variations.
|
|
||||||
|
|
||||||
}
|
|
||||||
|
|
||||||
@defproc[(name-process [id Any] [spawn-action Spawn]) Spawn]{
|
|
||||||
|
|
||||||
Returns a copy of the passed-in @racket[spawn] action structure, with
|
|
||||||
the @racket[debug-name] field set to the passed-in identifying value.
|
|
||||||
The debug name of a process is used in VM debug output. See also
|
|
||||||
@secref{logging}.
|
|
||||||
|
|
||||||
}
|
|
||||||
|
|
||||||
@section{Exiting and killing processes}
|
|
||||||
|
|
||||||
@defproc[(quit [who (Option PID) #f] [reason Any #f]) Action]{
|
|
||||||
|
|
||||||
Action causing the termination of a process. If @racket[who] is
|
|
||||||
omitted or @racket[#f], terminates the acting process; otherwise,
|
|
||||||
terminates the peer process having @racket[who] as its PID.
|
|
||||||
|
|
||||||
If @racket[reason] is supplied, it is included in the corresponding
|
|
||||||
action, and made available in any resulting @racket[absence-event]s.
|
|
||||||
|
|
||||||
Terminating the current process is as simple as:
|
|
||||||
|
|
||||||
@racketblock[(quit)]
|
|
||||||
|
|
||||||
When a process raises an exception that it does not catch, its
|
|
||||||
containing VM catches the exception and turns it into an implicit quit
|
|
||||||
action. In that case, the @racket[reason] will be the raised exception
|
|
||||||
itself.
|
|
||||||
|
|
||||||
}
|
|
||||||
|
|
||||||
@section{Cooperative scheduling}
|
|
||||||
|
|
||||||
@defform[(yield state-pattern k-expr)]{
|
|
||||||
|
|
||||||
Lets other processes in the system run for a step, returning to
|
|
||||||
evaluate @racket[k-expr] only after doing a complete round of the
|
|
||||||
scheduler.
|
|
||||||
|
|
||||||
The state of the yielding process will be matched against
|
|
||||||
@racket[state-pattern] when the process is resumed, and
|
|
||||||
@racket[k-expr] must evaluate to a @racket[transition].
|
|
||||||
|
|
||||||
}
|
|
||||||
|
|
||||||
@section{Creating nested VMs}
|
|
||||||
|
|
||||||
@defform[(spawn-vm maybe-vm-pid-binding maybe-boot-pid-binding
|
|
||||||
maybe-initial-state
|
|
||||||
maybe-debug-name
|
|
||||||
boot-action-expr ...)
|
|
||||||
#:grammar
|
|
||||||
[(maybe-vm-pid-binding (code:line)
|
|
||||||
(code:line #:vm-pid identifier))
|
|
||||||
(maybe-boot-pid-binding (code:line)
|
|
||||||
(code:line #:boot-pid identifier))
|
|
||||||
(maybe-initial-state (code:line)
|
|
||||||
(code:line #:initial-state expr))
|
|
||||||
(maybe-debug-name (code:line)
|
|
||||||
(code:line #:debug-name expr))
|
|
||||||
(boot-action-expr expr)]]{
|
|
||||||
|
|
||||||
Results in a @racket[spawn] action that starts a nested VM. The
|
|
||||||
primordial process in the new VM executes the boot-actions with the
|
|
||||||
given initial state. (If no initial state is supplied, @racket[(void)]
|
|
||||||
is used.)
|
|
||||||
|
|
||||||
If @racket[#:vm-pid] is present, the corresponding identifier is bound
|
|
||||||
in the boot-action expressions to the container-relative PID of the
|
|
||||||
new VM itself. If @racket[#:boot-pid] is present, however, the
|
|
||||||
corresponding identifier is bound to the new-VM-relative PID of the
|
|
||||||
primordial process in the new VM.
|
|
||||||
|
|
||||||
}
|
|
||||||
|
|
||||||
@section{Relaying across layers}
|
|
||||||
|
|
||||||
@defproc[(at-meta-level [preaction (PreAction State)] ...) (Action StateType)]{
|
|
||||||
|
|
||||||
Each VM gives its processes access to two distinct IPC facilities: the
|
|
||||||
@emph{internal} one, provided for the VM's processes to talk amongst
|
|
||||||
themselves, and the @emph{external} one, the network that the VM
|
|
||||||
itself is a process within.
|
|
||||||
|
|
||||||
Marketplace's actions can apply to either of those two networks. By
|
|
||||||
default, actions apply to the VM of the acting process directly, but
|
|
||||||
using @racket[at-meta-level] to wrap an action @emph{level-shifts} the
|
|
||||||
action to make it apply at the level of the acting process's VM's
|
|
||||||
container instead.
|
|
||||||
|
|
||||||
For example, wrapping an @racket[endpoint] in @racket[at-meta-level]
|
|
||||||
adds a subscription to the VM's container's network. Instead of
|
|
||||||
listening to sibling processes of the acting process, the new endpoint
|
|
||||||
will listen to sibling processes of the acting process's VM. In this
|
|
||||||
example, the primordial process in the nested VM creates an
|
|
||||||
endpoint in the VM's own network, the ground VM:
|
|
||||||
|
|
||||||
@racketblock[
|
|
||||||
(spawn-vm
|
|
||||||
(at-meta-level
|
|
||||||
(subscriber (tcp-channel ? (tcp-listener 5999) ?) ...)))
|
|
||||||
]
|
|
||||||
|
|
||||||
In this example, a new process is spawned as a sibling of the
|
|
||||||
nested VM rather than as a sibling of its primordial process:
|
|
||||||
|
|
||||||
@racketblock[
|
|
||||||
(spawn-vm
|
|
||||||
(at-meta-level
|
|
||||||
(spawn (transition/no-state (send-message 'hello-world)))))
|
|
||||||
]
|
|
||||||
|
|
||||||
Compare to this example, which spawns a sibling of the
|
|
||||||
nested VM's primordial process:
|
|
||||||
|
|
||||||
@racketblock[
|
|
||||||
(spawn-vm
|
|
||||||
(spawn (transition/no-state (send-message 'hello-world))))
|
|
||||||
]
|
|
||||||
|
|
||||||
}
|
|
|
@ -1,333 +0,0 @@
|
||||||
#lang scribble/manual
|
|
||||||
@require[racket/include]
|
|
||||||
@include{prelude.inc}
|
|
||||||
|
|
||||||
@title[#:tag "low-level-interface"]{Low-level interface}
|
|
||||||
|
|
||||||
@defmodule[marketplace]
|
|
||||||
|
|
||||||
At its heart, the interface between each @tech{process} and its
|
|
||||||
containing @tech{VM} is based on @tech{handler functions} exchanging
|
|
||||||
@tech{event} and @tech{action} structures with the VM. Both events and
|
|
||||||
actions are simple Racket structures.
|
|
||||||
|
|
||||||
This low-level interface between a VM and a process is analogous to
|
|
||||||
the @emph{system call interface} of a Unix-like operating system. The
|
|
||||||
@secref{high-level-interface} corresponds to the @emph{C library
|
|
||||||
interface} of a Unix-like operating system.
|
|
||||||
|
|
||||||
@section[#:tag "handler-functions"]{Handler Functions}
|
|
||||||
|
|
||||||
Each @deftech{handler function} is always associated with a particular
|
|
||||||
@tech{endpoint}, registered with the VM via
|
|
||||||
@racket[endpoint]/@racket[add-endpoint]. A handler
|
|
||||||
function for a given process with state type @racket[State] has type:
|
|
||||||
|
|
||||||
@racketblock[(EndpointEvent -> State -> (Transition State))]
|
|
||||||
|
|
||||||
That is, given an @racket[EndpointEvent] followed by the process's
|
|
||||||
current state, the handler should reply with a @racket[Transition]
|
|
||||||
containing a new process state and a collection of @racket[Action]s.
|
|
||||||
|
|
||||||
@deftogether[(
|
|
||||||
@deftype[(Handler State) (TrapK State)]
|
|
||||||
@deftype[(TrapK State) (EndpointEvent -> (InterruptK State))]
|
|
||||||
@deftype[(InterruptK State) (State -> (Transition State))]
|
|
||||||
)]{
|
|
||||||
|
|
||||||
Typed Racket types capturing various notions of handler function.
|
|
||||||
|
|
||||||
}
|
|
||||||
|
|
||||||
@section{Messages, Topics and Roles}
|
|
||||||
|
|
||||||
@declare-exporting[marketplace marketplace/sugar
|
|
||||||
#:use-sources (marketplace marketplace/sugar)]
|
|
||||||
|
|
||||||
@deftogether[(
|
|
||||||
@deftype[Message Any]
|
|
||||||
@deftype[Topic Any]
|
|
||||||
)]{
|
|
||||||
|
|
||||||
As previously mentioned, @tech{messages} are ordinary Racket values,
|
|
||||||
and @tech{topics} are ordinary Racket values which may have embedded
|
|
||||||
wildcards.
|
|
||||||
|
|
||||||
}
|
|
||||||
|
|
||||||
@deftogether[(
|
|
||||||
@defproc[(wild) Topic]
|
|
||||||
@defthing[#:kind "syntax" ? Topic]
|
|
||||||
)]{
|
|
||||||
|
|
||||||
Each time @racket[?] (or @racket[(wild)]) is used in an expression
|
|
||||||
context, it produces a fresh topic wildcard, suitable for use in a
|
|
||||||
topic pattern.
|
|
||||||
|
|
||||||
}
|
|
||||||
|
|
||||||
@deftogether[(
|
|
||||||
@defstruct*[role ([orientation Orientation] [topic Topic] [interest-type InterestType]) #:prefab]
|
|
||||||
@deftype[Role role]
|
|
||||||
)]{
|
|
||||||
|
|
||||||
Roles are almost always constructed by the
|
|
||||||
@racket[endpoint]/@racket[endpoint:] macros or by the VM
|
|
||||||
implementations themselves. User programs generally only need to
|
|
||||||
destructure @racket[role] instances.
|
|
||||||
|
|
||||||
A @racket[role] describes the conversational role of a peer as seen by
|
|
||||||
some process. For example, a subscriber to topic @racket['foo] with
|
|
||||||
interest-type @racket['participant] might receive a presence
|
|
||||||
notification carrying the role
|
|
||||||
|
|
||||||
@racketblock[(role 'publisher 'foo 'participant)]
|
|
||||||
|
|
||||||
Notice that the orientation of the role is the opposite of the
|
|
||||||
orientation of the endpoint.
|
|
||||||
|
|
||||||
}
|
|
||||||
|
|
||||||
@deftype[Orientation (U 'publisher 'subscriber)]{
|
|
||||||
|
|
||||||
Describes an endpoint's orientation: will it be acting as a publisher
|
|
||||||
of messages, or as a subscriber to messages? Publishers (orientation
|
|
||||||
@racket['publisher]) tend to use @racket[send-message] and tend to
|
|
||||||
respond to feedback from subscribers; subscribers
|
|
||||||
(@racket['subscriber]) tend to use @racket[send-feedback] and respond
|
|
||||||
to messages from publishers.
|
|
||||||
|
|
||||||
}
|
|
||||||
|
|
||||||
@deftype[InterestType (U 'participant 'observer 'everything)]{
|
|
||||||
|
|
||||||
Using interest-type @racket['participant] in an endpoint's role
|
|
||||||
indicates that the endpoint is intending to act as a genuine
|
|
||||||
participant in whatever protocol is associated with the endpoint and
|
|
||||||
its topic.
|
|
||||||
|
|
||||||
Using @racket['observer] indicates that the endpoint is intended to
|
|
||||||
@emph{monitor} other ongoing (participant) conversations instead.
|
|
||||||
Observer endpoints receive presence and absence notifications about
|
|
||||||
participant endpoints, but participant endpoints only receive
|
|
||||||
notifications about other participant endpoints, and not about
|
|
||||||
observer endpoints.
|
|
||||||
|
|
||||||
The @racket['observer] interest-type is intended to make it easier to
|
|
||||||
monitor resource demand and supply. The monitoring endpoints/processes
|
|
||||||
can react to changing demand by creating or destroying resources to
|
|
||||||
match.
|
|
||||||
|
|
||||||
Finally, the @racket['everything] interest-type receives notifications
|
|
||||||
about presence and absence of @emph{all} the types of endpoint,
|
|
||||||
@racket['participant], @racket['observer], and @racket['everything].
|
|
||||||
Endpoints with interest-type @racket['everything] are rare: they are
|
|
||||||
relevant for managing demand for @emph{observers}, as well as in some
|
|
||||||
cases of cross-layer presence/absence propagation. Most programs (and
|
|
||||||
even most drivers) will not need to use the @racket['everything]
|
|
||||||
interest-type.
|
|
||||||
|
|
||||||
}
|
|
||||||
|
|
||||||
@section[#:tag "endpoint-events"]{Endpoint Events}
|
|
||||||
|
|
||||||
@deftogether[(
|
|
||||||
@deftype[EndpointEvent (U PresenceEvent AbsenceEvent MessageEvent)]
|
|
||||||
@deftype[PresenceEvent presence-event]
|
|
||||||
@deftype[AbsenceEvent absence-event]
|
|
||||||
@deftype[MessageEvent message-event]
|
|
||||||
)]{
|
|
||||||
|
|
||||||
Endpoint events are passed to handler functions by VMs, conveying some
|
|
||||||
change in the world the process lives in. An endpoint event can signal
|
|
||||||
the arrival or departure of a conversational peer, or can deliver a
|
|
||||||
message that has been sent on a VM's IPC facility.
|
|
||||||
|
|
||||||
}
|
|
||||||
|
|
||||||
@defstruct*[presence-event ([role Role]) #:prefab]{
|
|
||||||
|
|
||||||
Indicates the arrival of a new conversational partner: an endpoint
|
|
||||||
with a topic that intersects our own, with @racket[Orientation]
|
|
||||||
opposite to our own.
|
|
||||||
|
|
||||||
The @racket[presence-event-role] describes the arriving peer, or more
|
|
||||||
precisely, describes the shared interest between ourselves and the new
|
|
||||||
peer. In particular, the @racket[role-orientation] of the
|
|
||||||
@racket[presence-event-role] is the orientation that the @emph{peer}
|
|
||||||
supplied in its @racket[add-endpoint] structure.
|
|
||||||
|
|
||||||
}
|
|
||||||
|
|
||||||
@defstruct*[absence-event ([role Role] [reason Any]) #:prefab]{
|
|
||||||
|
|
||||||
Indicates the departure of an existing conversational partner, through
|
|
||||||
either an explicit @racket[delete-endpoint] action or the implicit
|
|
||||||
deleting of all of a process's endpoints when a process exits.
|
|
||||||
|
|
||||||
The @racket[absence-event-role] describes the departing peer,
|
|
||||||
analogously to @racket[presence-event-role].
|
|
||||||
|
|
||||||
}
|
|
||||||
|
|
||||||
@defstruct*[message-event ([role Role] [message Message]) #:prefab]{
|
|
||||||
|
|
||||||
Indicates the arrival of a message matching the topic pattern in the
|
|
||||||
handler's @tech{endpoint}.
|
|
||||||
|
|
||||||
}
|
|
||||||
|
|
||||||
@section{Actions}
|
|
||||||
|
|
||||||
@declare-exporting[marketplace]
|
|
||||||
|
|
||||||
@deftogether[(
|
|
||||||
@deftype[(Action State) (U (PreAction State)
|
|
||||||
(yield State)
|
|
||||||
(at-meta-level State))]
|
|
||||||
@deftype[(PreAction State) (U (add-endpoint State)
|
|
||||||
delete-endpoint
|
|
||||||
send-message
|
|
||||||
(spawn State)
|
|
||||||
quit)]
|
|
||||||
)]{
|
|
||||||
|
|
||||||
Actions are requests from a process to its containing VM. If wrapped
|
|
||||||
in an @racket[at-meta-level] structure, the action is to apply to
|
|
||||||
@emph{the VM's own containing VM}; otherwise, the action applies to
|
|
||||||
the process's containing VM.
|
|
||||||
|
|
||||||
}
|
|
||||||
|
|
||||||
@deftogether[(
|
|
||||||
@defstruct*[at-meta-level ([preaction (PreAction State)]) #:prefab]
|
|
||||||
@deftype[(AtMetaLevel State) (at-meta-level State)]
|
|
||||||
)]{
|
|
||||||
|
|
||||||
An @racket[at-meta-level] structure wraps a plain action, and makes it
|
|
||||||
apply to the outer VM instead of the inner VM (the default).
|
|
||||||
|
|
||||||
}
|
|
||||||
|
|
||||||
@deftogether[(
|
|
||||||
@defstruct*[yield ([k (InterruptK State)]) #:prefab]
|
|
||||||
@deftype[(Yield State) (yield State)]
|
|
||||||
)]{
|
|
||||||
|
|
||||||
Because current VM implementations are cooperatively scheduled, it can
|
|
||||||
sometimes be necessary to explicitly yield the CPU to other processes
|
|
||||||
using a @racket[yield] action. When control returns to the yielding
|
|
||||||
process, the @racket[yield-k] is invoked.
|
|
||||||
|
|
||||||
}
|
|
||||||
|
|
||||||
@subsection[#:tag "endpoints-and-messages"]{Endpoints and Messages}
|
|
||||||
|
|
||||||
@deftogether[(
|
|
||||||
@defstruct*[add-endpoint ([pre-eid Any] [role Role] [handler (Handler State)]) #:prefab]
|
|
||||||
@deftype[(AddEndpoint State) (add-endpoint State)]
|
|
||||||
)]{
|
|
||||||
|
|
||||||
Creates a new endpoint subscribing to the given @racket[Role]. When
|
|
||||||
events pertaining to the given role occur, the @racket[Handler] is
|
|
||||||
invoked.@note{If invoked @racket[at-meta-level], subscribes to events
|
|
||||||
in the containing VM's container.}
|
|
||||||
|
|
||||||
The name of the new endpoint will be the @racket[pre-eid]; it must be
|
|
||||||
unique within the current process, but otherwise can be any value at
|
|
||||||
all. If the endpoint's name matches an existing endpoint, and the new
|
|
||||||
role is the same as the existing endpoint's role, the handler function
|
|
||||||
is @emph{replaced} in the existing endpoint.
|
|
||||||
|
|
||||||
To delete an endpoint, perform a @racket[delete-endpoint] action built
|
|
||||||
with the name of the endpoint to delete.
|
|
||||||
|
|
||||||
}
|
|
||||||
|
|
||||||
@deftogether[(
|
|
||||||
@defstruct*[delete-endpoint ([pre-eid Any] [reason Any]) #:prefab]
|
|
||||||
@deftype[DeleteEndpoint delete-endpoint]
|
|
||||||
)]{
|
|
||||||
|
|
||||||
Deletes an existing endpoint named @racket[pre-eid]. The given
|
|
||||||
@racket[reason] is passed along to peer endpoints as part of an
|
|
||||||
@racket[absence-event].
|
|
||||||
|
|
||||||
If no specific reason is needed, it is conventional to supply
|
|
||||||
@racket[#f] as the @racket[delete-endpoint-reason]. See also the
|
|
||||||
convenience @from[marketplace/sugar]{@racket[delete-endpoint]}
|
|
||||||
function from @racket[marketplace/sugar].
|
|
||||||
|
|
||||||
}
|
|
||||||
|
|
||||||
@deftogether[(
|
|
||||||
@defstruct*[send-message ([body Message] [orientation Orientation]) #:prefab]
|
|
||||||
@deftype[SendMessage send-message]
|
|
||||||
)]{
|
|
||||||
|
|
||||||
Sends a message to peers.@note{Or, if @racket[at-meta-level], peers of
|
|
||||||
the containing VM.} The given @racket[Orientation] should describe the
|
|
||||||
role the sender is playing when sending this message: usually, it will
|
|
||||||
be @racket['publisher], but when the message is @emph{feedback} for
|
|
||||||
some publisher, it will be @racket['subscriber].
|
|
||||||
@from[marketplace/sugar]{See also the @racket[send-message] and
|
|
||||||
@racket[send-feedback] convenience functions from
|
|
||||||
@racket[marketplace/sugar].}
|
|
||||||
|
|
||||||
}
|
|
||||||
|
|
||||||
@subsection{Process Management}
|
|
||||||
|
|
||||||
@deftogether[(
|
|
||||||
@defstruct*[spawn ([spec process-spec] [k (Option (PID -> (InterruptK State)))] [debug-name Any])
|
|
||||||
#:prefab]
|
|
||||||
@defstruct*[process-spec ([boot (PID -> CoTransition)]) #:prefab]
|
|
||||||
@deftype[CoTransition
|
|
||||||
(All (Result)
|
|
||||||
(All (State) (Transition State) -> Result)
|
|
||||||
-> Result)]
|
|
||||||
@deftype[(Spawn State) (spawn State)]
|
|
||||||
@deftype[ProcessSpec process-spec]
|
|
||||||
)]{
|
|
||||||
|
|
||||||
A @racket[spawn] requests the creation of a sibling process@note{If
|
|
||||||
wrapped in an @racket[at-meta-level], the new process will instead be
|
|
||||||
a sibling of the creating process's VM.}. The @racket[spawn-k] runs in
|
|
||||||
the context of the @emph{creating} process, communicating to it the
|
|
||||||
PID of the new process.
|
|
||||||
|
|
||||||
The @racket[spawn-spec] describes the new process to be created. Its
|
|
||||||
@racket[process-spec-boot] field is a function taking the PID of the
|
|
||||||
new process and returning a "cotransition". Cotransitions use a
|
|
||||||
second-order encoding of existential types to guarantee that the VM
|
|
||||||
remains oblivious to the specific process state type of the new
|
|
||||||
process. The downside of this approach is its syntactic and type
|
|
||||||
complexity: see @racket[spawn:] for an easier-to-use, higher-level
|
|
||||||
approach.
|
|
||||||
|
|
||||||
}
|
|
||||||
|
|
||||||
@deftogether[(
|
|
||||||
@defstruct*[quit ([pid (Option PID)] [reason Any]) #:prefab]
|
|
||||||
@deftype[Quit quit]
|
|
||||||
)]{
|
|
||||||
|
|
||||||
Kills a sibling process.@note{Or, if @racket[at-meta-level], a sibling
|
|
||||||
process of the containing VM.} If @racket[quit-pid] is @racket[#f],
|
|
||||||
kills the current process; otherwise, kills the process with the given
|
|
||||||
PID. The @racket[quit-reason] is passed on to peers of
|
|
||||||
currently-active endpoints in the process to be killed, as part of a
|
|
||||||
@racket[absence-event], just as if each active endpoint were deleted
|
|
||||||
manually before the process exited.
|
|
||||||
|
|
||||||
If no specific reason is needed, it is conventional to supply
|
|
||||||
@racket[#f] as the @racket[quit-reason].
|
|
||||||
|
|
||||||
}
|
|
||||||
|
|
||||||
@deftype[PID Number]{
|
|
||||||
|
|
||||||
In the current VM implementations, process IDs are simply numbers.
|
|
||||||
PIDs are scoped to and allocated by each individual VM instance.
|
|
||||||
|
|
||||||
}
|
|
|
@ -1,86 +0,0 @@
|
||||||
#lang scribble/manual
|
|
||||||
@require[racket/include]
|
|
||||||
@include{prelude.inc}
|
|
||||||
|
|
||||||
@require[(for-label marketplace/support/spy
|
|
||||||
marketplace/support/debug
|
|
||||||
marketplace/log)]
|
|
||||||
|
|
||||||
@title{Management and Monitoring}
|
|
||||||
|
|
||||||
@section{generic-spy}
|
|
||||||
|
|
||||||
@defmodule[marketplace/support/spy]{
|
|
||||||
|
|
||||||
@defproc[(generic-spy [label Any]) Spawn]{
|
|
||||||
|
|
||||||
Returns a @racket[spawn] action that, when executed, creates a process
|
|
||||||
with a @racket[#:subscriber] @racket[endpoint] listening for every
|
|
||||||
message. Each @racket[EndpointEvent] received by the endpoint is
|
|
||||||
printed to the current output port. Using this process gives a crude
|
|
||||||
trace of activity within a VM: @racket[presence-event]s and
|
|
||||||
@racket[absence-event]s (of @racket[#:publishers]) are logged, as is
|
|
||||||
each @racket['publisher] message sent to the VM's network.
|
|
||||||
|
|
||||||
}
|
|
||||||
|
|
||||||
}
|
|
||||||
|
|
||||||
@section[#:tag "logging"]{logging (MARKETPLACE_LOG)}
|
|
||||||
|
|
||||||
@defmodule*[(marketplace/log)]{
|
|
||||||
|
|
||||||
@defform[#:kind "environment variable" #:id MARKETPLACE_LOG MARKETPLACE_LOG]{
|
|
||||||
|
|
||||||
Set the @tt{MARKETPLACE_LOG} environment variable to "debug", "info",
|
|
||||||
"warning", "error" or "fatal" (i.e. any of Racket's
|
|
||||||
@racket[log-level?]s) to enable output of log messages at that level
|
|
||||||
and higher.
|
|
||||||
|
|
||||||
If @tt{MARKETPLACE_LOG} is not defined in the environment, @emph{no log
|
|
||||||
output will be produced}.
|
|
||||||
|
|
||||||
}
|
|
||||||
|
|
||||||
@defform[(marketplace-log level format-str arg ...)
|
|
||||||
#:grammar
|
|
||||||
((level expr)
|
|
||||||
(format-str expr)
|
|
||||||
(arg expr))]{
|
|
||||||
|
|
||||||
Analogous to Racket's core @racket[log-message], but uses
|
|
||||||
@racket[marketplace-root-logger] instead of the system logger. The
|
|
||||||
@racket[level] expression must evaluate to a level symbol (see
|
|
||||||
@racket[log-level?]), and @racket[format-str] must evaluate to a
|
|
||||||
format string for use with @racket[format].
|
|
||||||
|
|
||||||
}
|
|
||||||
|
|
||||||
@defthing[marketplace-root-logger logger?]{
|
|
||||||
|
|
||||||
The root logger for marketplace logging.
|
|
||||||
|
|
||||||
}
|
|
||||||
|
|
||||||
}
|
|
||||||
|
|
||||||
@section{debugger (experimental)}
|
|
||||||
|
|
||||||
@defmodule[marketplace/support/debug]{
|
|
||||||
|
|
||||||
@defproc[(debug [p Spawn]) Spawn]{
|
|
||||||
|
|
||||||
Translates a @racket[spawn] action to another spawn action which wraps
|
|
||||||
the to-be-spawned process in a debugging interface. Executing the
|
|
||||||
resulting action will not only create a process in the executing VM,
|
|
||||||
but will also open a debugger GUI.
|
|
||||||
|
|
||||||
N.B.: The debugger is experimental and likely to change quite quickly
|
|
||||||
and unpredictably.
|
|
||||||
|
|
||||||
See the file @filepath["examples/debug-chat.rkt"] for an example of the
|
|
||||||
use of @racket[debug].
|
|
||||||
|
|
||||||
}
|
|
||||||
|
|
||||||
}
|
|
|
@ -1,76 +0,0 @@
|
||||||
#lang scribble/manual
|
|
||||||
@require[racket/include]
|
|
||||||
@include{prelude.inc}
|
|
||||||
|
|
||||||
@title[#:tag "marketplace"]{Marketplace: Network-Aware Programming}
|
|
||||||
@;{Marketplace: A Functional Operating System}
|
|
||||||
@;{Marketplace: A Functional Network Operating System}
|
|
||||||
@;{Marketplace: A Functional Distributed Operating System}
|
|
||||||
|
|
||||||
@author[(author+email "Tony Garnock-Jones" "tonyg@ccs.neu.edu")]
|
|
||||||
|
|
||||||
@bold{Every program is a network.}
|
|
||||||
This is the insight behind the π-calculus. Encoding a program as a
|
|
||||||
π-calculus term shows it as a network of communicating processes. It
|
|
||||||
is also one of the original inspirations for Smalltalk, where every
|
|
||||||
object, every value, was imagined to be a separate computer in a vast
|
|
||||||
network, and where objects communicated by message-passing.
|
|
||||||
|
|
||||||
@bold{Every program is part of a network.}
|
|
||||||
A program that computes a result but cannot communicate it is useless
|
|
||||||
indeed. Every complete program both @emph{computes} and
|
|
||||||
@emph{communicates}. Furthermore, it does so with some finite set of
|
|
||||||
@emph{resources}, which it must carefully manage.
|
|
||||||
|
|
||||||
@bold{Our programming languages do not recognise that every program is
|
|
||||||
a network.} They blur the distinction between stateful and stateless
|
|
||||||
portions of a program, making it difficult for programmers to reason
|
|
||||||
about concurrency, contention, and distribution. They often treat
|
|
||||||
partial failure as an afterthought, despite its importance in
|
|
||||||
reasoning about program behaviour, particularly in connection with the
|
|
||||||
effect of exceptions on stateful programs. They seldom consider issues
|
|
||||||
of trust and security.
|
|
||||||
|
|
||||||
@bold{Our programming languages do not recognise that every program is part of a network.}
|
|
||||||
They treat communication with the outside world in an ad-hoc manner.
|
|
||||||
They frequently treat network communication separately from
|
|
||||||
@tt{1950s-style terminal input and output}. They force the programmer
|
|
||||||
to divine failures in other parts of the network by arcane means such
|
|
||||||
as timeouts and examining the entrails of dead communication channels.
|
|
||||||
They offer no support for allocating or releasing local resources in
|
|
||||||
response to changes in other parts of the network. They seldom
|
|
||||||
consider issues of trust and security.
|
|
||||||
|
|
||||||
@bold{Marketplace is a network-aware programming language.} As a
|
|
||||||
corollary, because every program not only computes but also
|
|
||||||
communicates and manages its resources, Marketplace is also a
|
|
||||||
distributed operating system.
|
|
||||||
|
|
||||||
By recognising that programs communicate both
|
|
||||||
@emph{internally} (between subprograms) and @emph{externally} (between
|
|
||||||
peers), we recognise an inherently recursive layered architecture. We
|
|
||||||
see at every level the @emph{same} concerns of resource management,
|
|
||||||
location of mutable state, failure detection and recovery, access
|
|
||||||
control, I/O and user interface, debugging and profiling.
|
|
||||||
|
|
||||||
Marketplace addresses these concerns with a small set of primitives
|
|
||||||
chosen to make network programming in-the-small as flexible, scalable,
|
|
||||||
manageable and securable as network programming in-the-large---and
|
|
||||||
vice versa.
|
|
||||||
|
|
||||||
@;{
|
|
||||||
Networks must be manageable. Networks must be monitorable. Networks
|
|
||||||
must tolerate partial failure. Networks must scale. Networks must
|
|
||||||
communicate with other networks, via yet other networks.
|
|
||||||
}
|
|
||||||
|
|
||||||
@local-table-of-contents[]
|
|
||||||
|
|
||||||
@;@include-section["background.scrbl"]
|
|
||||||
@include-section["concepts.scrbl"]
|
|
||||||
@include-section["highlevel.scrbl"]
|
|
||||||
@include-section["lowlevel.scrbl"]
|
|
||||||
@include-section["drivers.scrbl"]
|
|
||||||
@;@include-section["writing-drivers.scrbl"]
|
|
||||||
@include-section["management-and-monitoring.scrbl"]
|
|
||||||
@include-section["examples.scrbl"]
|
|
|
@ -1,31 +0,0 @@
|
||||||
;; -*- scheme -*-
|
|
||||||
(require scribble/racket
|
|
||||||
scribble/eval
|
|
||||||
scriblib/footnote
|
|
||||||
|
|
||||||
slideshow/pict
|
|
||||||
"vm-pictures.rkt"
|
|
||||||
|
|
||||||
"from.rkt"
|
|
||||||
|
|
||||||
(for-syntax racket)
|
|
||||||
(for-label typed/racket/base))
|
|
||||||
|
|
||||||
(require (for-label (only-in marketplace/drivers/tcp-bare tcp)
|
|
||||||
marketplace/sugar))
|
|
||||||
|
|
||||||
;; TODO: make it display "=" instead of ":" connecting the defined
|
|
||||||
;; type to the definition.
|
|
||||||
(define-syntax deftype
|
|
||||||
(lambda (stx)
|
|
||||||
(syntax-case stx ()
|
|
||||||
[(_ (t a ...) d desc ...)
|
|
||||||
#`(defthing #:kind "type" t
|
|
||||||
;; This is in column zero because scribble is overscrupulous about location preservation.
|
|
||||||
#,(quasisyntax/loc #'d (All (a ...) d))
|
|
||||||
desc ...)]
|
|
||||||
[(_ t d desc ...)
|
|
||||||
#`(defthing #:kind "type" t d desc ...)])))
|
|
||||||
|
|
||||||
(define (vm-figure p)
|
|
||||||
(centered (to-element (render (scale p 1.2) #:target 'pict))))
|
|
|
@ -1,113 +0,0 @@
|
||||||
#lang racket/base
|
|
||||||
|
|
||||||
(require (only-in racket/math pi))
|
|
||||||
(require slideshow/pict)
|
|
||||||
(require file/convertible)
|
|
||||||
|
|
||||||
(provide (all-defined-out))
|
|
||||||
|
|
||||||
(define default-process-height 98)
|
|
||||||
|
|
||||||
(define default-font (make-parameter 'roman))
|
|
||||||
|
|
||||||
(define final-border (make-parameter 1))
|
|
||||||
|
|
||||||
(define process-angle (make-parameter 90))
|
|
||||||
(define process-width (make-parameter 24))
|
|
||||||
(define process-corner (make-parameter 6))
|
|
||||||
(define process-height (make-parameter default-process-height))
|
|
||||||
(define process-gap (make-parameter 6))
|
|
||||||
(define process-fill-color (make-parameter "white"))
|
|
||||||
|
|
||||||
(define PROCESS-SHADED (list #xdd #xdd #xdd))
|
|
||||||
|
|
||||||
(define leg-offset (make-parameter 4))
|
|
||||||
(define leg-width (make-parameter 2))
|
|
||||||
(define leg-spot-width (make-parameter 4))
|
|
||||||
|
|
||||||
(define (default-leg-height)
|
|
||||||
(/ (network-height) 2))
|
|
||||||
|
|
||||||
(define (meta-leg-height)
|
|
||||||
(+ (default-leg-height) (vm-height) (network-height)))
|
|
||||||
|
|
||||||
(define network-height (make-parameter 12))
|
|
||||||
(define vm-height (make-parameter 27))
|
|
||||||
(define process-label-size (make-parameter 12))
|
|
||||||
(define network-label-size (make-parameter 9))
|
|
||||||
(define vm-label-size (make-parameter 12))
|
|
||||||
(define ellipsis-size (make-parameter 24))
|
|
||||||
|
|
||||||
(define (process label)
|
|
||||||
(cb-superimpose
|
|
||||||
(colorize (filled-rounded-rectangle (process-width) (process-height) (process-corner))
|
|
||||||
(process-fill-color))
|
|
||||||
(rounded-rectangle (process-width) (process-height) (process-corner))
|
|
||||||
(vc-append (text label (default-font) (process-label-size) (d2r (process-angle)))
|
|
||||||
(blank (/ (- (process-width) (process-label-size)) 2)))))
|
|
||||||
|
|
||||||
(define (process-group . ps)
|
|
||||||
(apply hb-append (process-gap) ps))
|
|
||||||
|
|
||||||
(define (process-space [n 1])
|
|
||||||
(blank (+ (* (- n 1) (/ (process-width) 2))
|
|
||||||
(- (/ (process-width) 2) (* 2 (process-gap)))) (process-height)))
|
|
||||||
|
|
||||||
(define (vm-label str)
|
|
||||||
(text str (default-font) (vm-label-size) (d2r 0)))
|
|
||||||
|
|
||||||
(define (network-label str)
|
|
||||||
(text str (default-font) (network-label-size) (d2r 0)))
|
|
||||||
|
|
||||||
(define (vm label net-label . ps)
|
|
||||||
(define ps-pict (apply process-group ps))
|
|
||||||
(define label-width (max (pict-width label) (pict-width net-label)))
|
|
||||||
(define width (max (+ label-width (* 2 (max (vm-label-size) (network-label-size))))
|
|
||||||
(pict-width ps-pict)))
|
|
||||||
(vl-append ps-pict
|
|
||||||
(cb-superimpose (colorize (filled-rectangle width (network-height))
|
|
||||||
(process-fill-color))
|
|
||||||
(rectangle width (network-height))
|
|
||||||
net-label)
|
|
||||||
(cc-superimpose (colorize (filled-rectangle width (vm-height))
|
|
||||||
(process-fill-color))
|
|
||||||
(rectangle width (vm-height))
|
|
||||||
label)))
|
|
||||||
|
|
||||||
(define (process-ellipsis)
|
|
||||||
(cc-superimpose (text ". . ." (default-font) (ellipsis-size) 0)
|
|
||||||
(blank 0 (process-height))))
|
|
||||||
|
|
||||||
(define (d2r d)
|
|
||||||
(* pi (/ d 180.0)))
|
|
||||||
|
|
||||||
(define (leg p offset height)
|
|
||||||
(define x (+ (/ (pict-width p) 2) (* offset (leg-offset))))
|
|
||||||
(define y (pict-height p))
|
|
||||||
(define leg-pict (vc-append (vline (leg-width) (- height (/ (leg-spot-width) 2)))
|
|
||||||
(disk (leg-spot-width) #:draw-border? #f)))
|
|
||||||
(pin-over p (- x (/ (pict-width leg-pict) 2)) y leg-pict))
|
|
||||||
|
|
||||||
(define (relay-legs p)
|
|
||||||
(leg (leg p 1 (default-leg-height)) -1 (meta-leg-height)))
|
|
||||||
|
|
||||||
(define (local-leg p)
|
|
||||||
(leg p 0 (default-leg-height)))
|
|
||||||
|
|
||||||
(define (render p #:target [target (string->symbol (or (getenv "VM_PICTURES_TARGET") "eps"))])
|
|
||||||
(define final-pict (cc-superimpose (blank (+ (pict-width p) (* 2 (final-border)))
|
|
||||||
(+ (pict-height p) (* 2 (final-border))))
|
|
||||||
(panorama p)))
|
|
||||||
(case target
|
|
||||||
[(pict)
|
|
||||||
final-pict]
|
|
||||||
[(screen)
|
|
||||||
;; FFS. This connects to the display even if you don't use it.
|
|
||||||
;; (local-require racket/gui/base)
|
|
||||||
;; (show-pict final-pict 800 600)
|
|
||||||
(log-error "You need to uncomment a couple of lines in vm-pictures.rkt")
|
|
||||||
(void)]
|
|
||||||
[(png)
|
|
||||||
(display (convert final-pict 'png-bytes))]
|
|
||||||
[(eps)
|
|
||||||
(display (convert final-pict 'eps-bytes))]))
|
|
|
@ -1,12 +0,0 @@
|
||||||
#lang scribble/manual
|
|
||||||
@require[racket/include]
|
|
||||||
@include{prelude.inc}
|
|
||||||
|
|
||||||
@title[#:tag "writing-new-drivers"]{Writing New Drivers}
|
|
||||||
|
|
||||||
*** ground-vm's usage of Racket evt?s
|
|
||||||
TODO
|
|
||||||
example of chat-client.rkt
|
|
||||||
|
|
||||||
*** pseudo-substruct
|
|
||||||
TODO
|
|
|
@ -1,47 +0,0 @@
|
||||||
#lang racket/base
|
|
||||||
|
|
||||||
(provide prop:struct-map
|
|
||||||
struct-mappable?
|
|
||||||
extract-struct-mapper
|
|
||||||
struct-map
|
|
||||||
struct-map/accumulator)
|
|
||||||
|
|
||||||
(define-values (prop:struct-map struct-mappable? extract-struct-mapper)
|
|
||||||
(make-struct-type-property 'struct-map))
|
|
||||||
|
|
||||||
;; (X -> Y) Struct<X> -> Struct<Y>
|
|
||||||
(define (struct-map f x)
|
|
||||||
(define-values (result acc)
|
|
||||||
(struct-map* 'struct-map (lambda (v acc) (values (f v) acc)) (void) x))
|
|
||||||
result)
|
|
||||||
|
|
||||||
;; (X Seed -> Y Seed) Seed Struct<X> -> Struct<Y> Seed
|
|
||||||
(define (struct-map/accumulator f seed x)
|
|
||||||
(struct-map* 'struct-map/accumulator f seed x))
|
|
||||||
|
|
||||||
(define (struct-map* name f seed x)
|
|
||||||
(define m (cond
|
|
||||||
[(struct-mappable? x) (extract-struct-mapper x)]
|
|
||||||
[(prefab-struct-key x) => prefab-struct-mapper]
|
|
||||||
[(struct? x)
|
|
||||||
(define-values (struct-type skipped?) (struct-info x))
|
|
||||||
(when skipped? (error name "Partial struct-info for ~v" x))
|
|
||||||
(transparent-struct-mapper struct-type)]
|
|
||||||
[else (error name "No struct-map property or mapper for ~v" x)]))
|
|
||||||
(m f seed x))
|
|
||||||
|
|
||||||
(define ((prefab-struct-mapper key) f initial-seed x)
|
|
||||||
(define-values (new-fields final-seed)
|
|
||||||
(for/fold ([new-fields '()] [old-seed initial-seed])
|
|
||||||
([old-field (cdr (vector->list (struct->vector x)))])
|
|
||||||
(define-values (new-field new-seed) (f old-field old-seed))
|
|
||||||
(values (cons new-field new-fields) new-seed)))
|
|
||||||
(values (apply make-prefab-struct key (reverse new-fields)) final-seed))
|
|
||||||
|
|
||||||
(define ((transparent-struct-mapper struct-type) f initial-seed x)
|
|
||||||
(define-values (new-fields final-seed)
|
|
||||||
(for/fold ([new-fields '()] [old-seed initial-seed])
|
|
||||||
([old-field (cdr (vector->list (struct->vector x)))])
|
|
||||||
(define-values (new-field new-seed) (f old-field old-seed))
|
|
||||||
(values (cons new-field new-fields) new-seed)))
|
|
||||||
(values (apply (struct-type-make-constructor struct-type) (reverse new-fields)) final-seed))
|
|
96
structs.rkt
96
structs.rkt
|
@ -1,96 +0,0 @@
|
||||||
#lang racket/base
|
|
||||||
|
|
||||||
(provide (all-defined-out))
|
|
||||||
|
|
||||||
;; (define-type Orientation (U 'publisher 'subscriber))
|
|
||||||
|
|
||||||
(struct role (orientation ;; Orientation
|
|
||||||
topic ;; Topic
|
|
||||||
interest-type ;; InterestType
|
|
||||||
)
|
|
||||||
#:transparent)
|
|
||||||
|
|
||||||
;; (define-type Message Topic) ;; Cheesy.
|
|
||||||
|
|
||||||
;; (define-type InterestType (U 'participant 'observer 'everything))
|
|
||||||
|
|
||||||
;; (define-type (Handler State) (TrapK EndpointEvent State))
|
|
||||||
|
|
||||||
;; (define-type (InterruptK State) (State -> (Transition State)))
|
|
||||||
;; (define-type (TrapK Event State) (Event -> (InterruptK State)))
|
|
||||||
|
|
||||||
;; (define-type EndpointEvent (U PresenceEvent
|
|
||||||
;; AbsenceEvent
|
|
||||||
;; MessageEvent))
|
|
||||||
|
|
||||||
(struct presence-event (role) #:transparent)
|
|
||||||
(struct absence-event (role reason) #:transparent)
|
|
||||||
(struct message-event (role message) #:transparent)
|
|
||||||
|
|
||||||
(struct transition (state ;; State
|
|
||||||
actions ;; (ActionTree State)
|
|
||||||
)
|
|
||||||
#:transparent)
|
|
||||||
|
|
||||||
;; (define-type (ActionTree State) (Constreeof (Action State)))
|
|
||||||
|
|
||||||
;; Existential quantification over State
|
|
||||||
;; (define-type CoTransition (All (Result) (All (State) (Transition State) -> Result) -> Result))
|
|
||||||
|
|
||||||
;; Specification of a new process
|
|
||||||
(struct process-spec (boot ;; (PID -> CoTransition)
|
|
||||||
)
|
|
||||||
#:transparent)
|
|
||||||
;; (define-type ProcessSpec process-spec)
|
|
||||||
|
|
||||||
;; (define-type (PreAction State) (U (add-endpoint State)
|
|
||||||
;; delete-endpoint
|
|
||||||
;; send-message
|
|
||||||
;; (spawn State)
|
|
||||||
;; quit))
|
|
||||||
|
|
||||||
(struct add-endpoint (pre-eid ;; PreEID
|
|
||||||
role ;; Role
|
|
||||||
handler ;; (Handler State)
|
|
||||||
)
|
|
||||||
#:transparent)
|
|
||||||
|
|
||||||
(struct delete-endpoint (pre-eid ;; PreEID
|
|
||||||
reason ;; Reason
|
|
||||||
)
|
|
||||||
#:transparent)
|
|
||||||
|
|
||||||
(struct send-message (body ;; Message
|
|
||||||
orientation ;; Orientation
|
|
||||||
)
|
|
||||||
#:transparent)
|
|
||||||
|
|
||||||
(struct spawn (spec ;; process-spec
|
|
||||||
k ;; (Option (PID -> (InterruptK State)))
|
|
||||||
debug-name ;; Any
|
|
||||||
)
|
|
||||||
#:transparent)
|
|
||||||
|
|
||||||
(struct quit (pid ;; (Option PID) ;; #f = suicide
|
|
||||||
reason ;; Reason
|
|
||||||
)
|
|
||||||
#:transparent)
|
|
||||||
|
|
||||||
;; (define-type (Action State) (U (PreAction State)
|
|
||||||
;; (yield State)
|
|
||||||
;; (at-meta-level State)))
|
|
||||||
|
|
||||||
(struct yield (k ;; (InterruptK State)
|
|
||||||
)
|
|
||||||
#:transparent)
|
|
||||||
|
|
||||||
(struct at-meta-level (preaction ;; (PreAction State)
|
|
||||||
)
|
|
||||||
#:transparent)
|
|
||||||
|
|
||||||
;; (define-type PID Number)
|
|
||||||
|
|
||||||
;;; Local Variables:
|
|
||||||
;;; eval: (put 'transition 'scheme-indent-function 1)
|
|
||||||
;;; eval: (put 'transition/no-state 'scheme-indent-function 0)
|
|
||||||
;;; End:
|
|
392
sugar.rkt
392
sugar.rkt
|
@ -1,392 +0,0 @@
|
||||||
#lang racket/base
|
|
||||||
|
|
||||||
(require (for-syntax syntax/parse))
|
|
||||||
(require (for-syntax racket/base))
|
|
||||||
|
|
||||||
(require racket/match)
|
|
||||||
(require (prefix-in core: "main.rkt"))
|
|
||||||
(require (except-in "main.rkt"
|
|
||||||
at-meta-level
|
|
||||||
spawn
|
|
||||||
yield
|
|
||||||
transition
|
|
||||||
delete-endpoint
|
|
||||||
send-message
|
|
||||||
quit))
|
|
||||||
(require "support/dsl-untyped.rkt")
|
|
||||||
|
|
||||||
(provide (all-from-out "main.rkt")
|
|
||||||
|
|
||||||
transition
|
|
||||||
delete-endpoint
|
|
||||||
send-message
|
|
||||||
send-feedback
|
|
||||||
quit
|
|
||||||
sequence-actions
|
|
||||||
(rename-out [core:wild wild])
|
|
||||||
|
|
||||||
name-endpoint
|
|
||||||
let-fresh
|
|
||||||
observe-subscribers
|
|
||||||
observe-subscribers/everything
|
|
||||||
observe-publishers
|
|
||||||
observe-publishers/everything
|
|
||||||
publisher
|
|
||||||
subscriber
|
|
||||||
build-endpoint
|
|
||||||
|
|
||||||
?
|
|
||||||
transition/no-state
|
|
||||||
spawn
|
|
||||||
spawn/continue
|
|
||||||
name-process
|
|
||||||
yield
|
|
||||||
at-meta-level
|
|
||||||
spawn-vm
|
|
||||||
ground-vm)
|
|
||||||
|
|
||||||
;; transition : (All (State) State (core:ActionTree State) * -> (core:Transition State))
|
|
||||||
(define (transition state . actions)
|
|
||||||
(core:transition state actions))
|
|
||||||
|
|
||||||
(define (delete-endpoint id [reason #f])
|
|
||||||
(core:delete-endpoint id reason))
|
|
||||||
|
|
||||||
;; send-message : (case-> [Any -> core:send-message]
|
|
||||||
;; [Any core:Orientation -> core:send-message])
|
|
||||||
(define (send-message body [orientation 'publisher])
|
|
||||||
(core:send-message body orientation))
|
|
||||||
|
|
||||||
(define (send-feedback body)
|
|
||||||
(core:send-message body 'subscriber))
|
|
||||||
|
|
||||||
;; quit : (case-> [-> core:quit]
|
|
||||||
;; [(Option core:PID) -> core:quit]
|
|
||||||
;; [(Option core:PID) Any -> core:quit])
|
|
||||||
(define (quit [who #f] [reason #f])
|
|
||||||
(core:quit who reason))
|
|
||||||
|
|
||||||
;; sequence-actions : (All (State)
|
|
||||||
;; (core:Transition State)
|
|
||||||
;; (U (core:ActionTree State) (State -> (core:Transition State))) *
|
|
||||||
;; -> (core:Transition State))
|
|
||||||
(define (sequence-actions t . more-actions-and-transformers)
|
|
||||||
(match-define (core:transition initial-state initial-actions) t)
|
|
||||||
(let loop ((state initial-state)
|
|
||||||
(actions initial-actions)
|
|
||||||
(items more-actions-and-transformers))
|
|
||||||
(match items
|
|
||||||
['()
|
|
||||||
(core:transition state actions)]
|
|
||||||
[(cons item remaining-items)
|
|
||||||
(if (procedure? item)
|
|
||||||
(match (item state)
|
|
||||||
[(core:transition new-state more-actions)
|
|
||||||
(loop new-state
|
|
||||||
(cons actions more-actions)
|
|
||||||
remaining-items)])
|
|
||||||
(loop state
|
|
||||||
(cons actions item)
|
|
||||||
remaining-items))])))
|
|
||||||
|
|
||||||
(define&provide-dsl-helper-syntaxes "endpoint definition context"
|
|
||||||
[match-state
|
|
||||||
match-orientation
|
|
||||||
match-conversation
|
|
||||||
match-interest-type
|
|
||||||
match-reason
|
|
||||||
on-presence
|
|
||||||
on-absence
|
|
||||||
on-message])
|
|
||||||
|
|
||||||
;; Must handle:
|
|
||||||
;; - orientation
|
|
||||||
;; - interest-type
|
|
||||||
;; - let-name
|
|
||||||
;; - naming of endpoints
|
|
||||||
;; - state matching
|
|
||||||
;; - conversation (and generally role) matching
|
|
||||||
;; - presence event handling
|
|
||||||
;; - absence event handling (including reason matching)
|
|
||||||
;; - message event handling (including message matching)
|
|
||||||
|
|
||||||
(define (name-endpoint n e)
|
|
||||||
(match e
|
|
||||||
[(core:add-endpoint _ role handler)
|
|
||||||
(core:add-endpoint n role handler)]))
|
|
||||||
|
|
||||||
(define-syntax-rule (let-fresh (id ...) exp ...)
|
|
||||||
(let ((id (gensym 'id)) ...) exp ...))
|
|
||||||
|
|
||||||
(define-syntax-rule (observe-subscribers topic clause ...)
|
|
||||||
(build-endpoint (gensym 'anonymous-endpoint)
|
|
||||||
(core:role 'publisher topic 'observer)
|
|
||||||
clause ...))
|
|
||||||
|
|
||||||
(define-syntax-rule (observe-subscribers/everything topic clause ...)
|
|
||||||
(build-endpoint (gensym 'anonymous-endpoint)
|
|
||||||
(core:role 'publisher topic 'everything)
|
|
||||||
clause ...))
|
|
||||||
|
|
||||||
(define-syntax-rule (observe-publishers topic clause ...)
|
|
||||||
(build-endpoint (gensym 'anonymous-endpoint)
|
|
||||||
(core:role 'subscriber topic 'observer)
|
|
||||||
clause ...))
|
|
||||||
|
|
||||||
(define-syntax-rule (observe-publishers/everything topic clause ...)
|
|
||||||
(build-endpoint (gensym 'anonymous-endpoint)
|
|
||||||
(core:role 'subscriber topic 'everything)
|
|
||||||
clause ...))
|
|
||||||
|
|
||||||
(define-syntax-rule (publisher topic clause ...)
|
|
||||||
(build-endpoint (gensym 'anonymous-endpoint)
|
|
||||||
(core:role 'publisher topic 'participant)
|
|
||||||
clause ...))
|
|
||||||
|
|
||||||
(define-syntax-rule (subscriber topic clause ...)
|
|
||||||
(build-endpoint (gensym 'anonymous-endpoint)
|
|
||||||
(core:role 'subscriber topic 'participant)
|
|
||||||
clause ...))
|
|
||||||
|
|
||||||
(define-syntax build-endpoint
|
|
||||||
(lambda (stx)
|
|
||||||
(define (combine-handler-clauses clauses-stx
|
|
||||||
stateful?
|
|
||||||
state-stx
|
|
||||||
orientation-stx
|
|
||||||
conversation-stx
|
|
||||||
interest-type-stx
|
|
||||||
reason-stx)
|
|
||||||
|
|
||||||
(define (do-tail new-clauses-stx)
|
|
||||||
(combine-handler-clauses new-clauses-stx
|
|
||||||
stateful?
|
|
||||||
state-stx
|
|
||||||
orientation-stx
|
|
||||||
conversation-stx
|
|
||||||
interest-type-stx
|
|
||||||
reason-stx))
|
|
||||||
|
|
||||||
(define (stateful-lift context exprs-stx)
|
|
||||||
(if stateful?
|
|
||||||
(syntax-case exprs-stx ()
|
|
||||||
[(expr)
|
|
||||||
#`(match-lambda [#,state-stx expr])]
|
|
||||||
[_
|
|
||||||
(raise-syntax-error #f
|
|
||||||
(format "Expected exactly one expression resulting in a transition, in ~a handler"
|
|
||||||
context)
|
|
||||||
stx
|
|
||||||
exprs-stx)])
|
|
||||||
(syntax-case exprs-stx ()
|
|
||||||
[(expr ...)
|
|
||||||
#`(lambda (state) (core:transition state (list expr ...)))])))
|
|
||||||
|
|
||||||
(syntax-case clauses-stx (match-state
|
|
||||||
match-orientation
|
|
||||||
match-conversation
|
|
||||||
match-interest-type
|
|
||||||
match-reason
|
|
||||||
on-presence
|
|
||||||
on-absence
|
|
||||||
on-message)
|
|
||||||
[() '()]
|
|
||||||
|
|
||||||
[((match-state pat-stx inner-clause ...) outer-clause ...)
|
|
||||||
(append (combine-handler-clauses (syntax (inner-clause ...))
|
|
||||||
#t
|
|
||||||
#'pat-stx
|
|
||||||
orientation-stx
|
|
||||||
conversation-stx
|
|
||||||
interest-type-stx
|
|
||||||
reason-stx)
|
|
||||||
(do-tail (syntax (outer-clause ...))))]
|
|
||||||
|
|
||||||
[((match-orientation pat-stx inner-clause ...) outer-clause ...)
|
|
||||||
(append (combine-handler-clauses (syntax (inner-clause ...))
|
|
||||||
stateful?
|
|
||||||
state-stx
|
|
||||||
#'pat-stx
|
|
||||||
conversation-stx
|
|
||||||
interest-type-stx
|
|
||||||
reason-stx)
|
|
||||||
(do-tail (syntax (outer-clause ...))))]
|
|
||||||
|
|
||||||
[((match-conversation pat-stx inner-clause ...) outer-clause ...)
|
|
||||||
(append (combine-handler-clauses (syntax (inner-clause ...))
|
|
||||||
stateful?
|
|
||||||
state-stx
|
|
||||||
orientation-stx
|
|
||||||
#'pat-stx
|
|
||||||
interest-type-stx
|
|
||||||
reason-stx)
|
|
||||||
(do-tail (syntax (outer-clause ...))))]
|
|
||||||
|
|
||||||
[((match-interest-type pat-stx inner-clause ...) outer-clause ...)
|
|
||||||
(append (combine-handler-clauses (syntax (inner-clause ...))
|
|
||||||
stateful?
|
|
||||||
state-stx
|
|
||||||
orientation-stx
|
|
||||||
conversation-stx
|
|
||||||
#'pat-stx
|
|
||||||
reason-stx)
|
|
||||||
(do-tail (syntax (outer-clause ...))))]
|
|
||||||
|
|
||||||
[((match-reason pat-stx inner-clause ...) outer-clause ...)
|
|
||||||
(append (combine-handler-clauses (syntax (inner-clause ...))
|
|
||||||
stateful?
|
|
||||||
state-stx
|
|
||||||
orientation-stx
|
|
||||||
conversation-stx
|
|
||||||
interest-type-stx
|
|
||||||
#'pat-stx)
|
|
||||||
(do-tail (syntax (outer-clause ...))))]
|
|
||||||
|
|
||||||
[((on-presence expr ...) outer-clause ...)
|
|
||||||
(cons #`[(core:presence-event (core:role #,orientation-stx
|
|
||||||
#,conversation-stx
|
|
||||||
#,interest-type-stx))
|
|
||||||
#,(stateful-lift 'on-presence (syntax (expr ...)))]
|
|
||||||
(do-tail (syntax (outer-clause ...))))]
|
|
||||||
|
|
||||||
[((on-absence expr ...) outer-clause ...)
|
|
||||||
(cons #`[(core:absence-event (core:role #,orientation-stx
|
|
||||||
#,conversation-stx
|
|
||||||
#,interest-type-stx)
|
|
||||||
#,reason-stx)
|
|
||||||
#,(stateful-lift 'on-absence (syntax (expr ...)))]
|
|
||||||
(do-tail (syntax (outer-clause ...))))]
|
|
||||||
|
|
||||||
[((on-message [message-pat expr ...] ...) outer-clause ...)
|
|
||||||
(cons #`[(core:message-event (core:role #,orientation-stx
|
|
||||||
#,conversation-stx
|
|
||||||
#,interest-type-stx)
|
|
||||||
message)
|
|
||||||
(match message
|
|
||||||
#,@(map (lambda (message-clause)
|
|
||||||
(syntax-case message-clause ()
|
|
||||||
([message-pat expr ...]
|
|
||||||
#`[message-pat #,(stateful-lift 'on-message
|
|
||||||
(syntax (expr ...)))])))
|
|
||||||
(syntax->list (syntax ([message-pat expr ...] ...))))
|
|
||||||
[_ (lambda (state) (core:transition state '()))])]
|
|
||||||
(do-tail (syntax (outer-clause ...))))]
|
|
||||||
|
|
||||||
[(unknown-clause outer-clause ...)
|
|
||||||
(raise-syntax-error #f
|
|
||||||
"Illegal clause in endpoint definition"
|
|
||||||
stx
|
|
||||||
#'unknown-clause)]))
|
|
||||||
|
|
||||||
(syntax-case stx ()
|
|
||||||
[(dummy pre-eid-exp role-exp handler-clause ...)
|
|
||||||
#`(core:add-endpoint pre-eid-exp
|
|
||||||
role-exp
|
|
||||||
(match-lambda
|
|
||||||
#,@(reverse
|
|
||||||
(combine-handler-clauses
|
|
||||||
(syntax (handler-clause ...))
|
|
||||||
#f
|
|
||||||
(syntax old-state)
|
|
||||||
(syntax _)
|
|
||||||
(syntax _)
|
|
||||||
(syntax _)
|
|
||||||
(syntax _)))
|
|
||||||
[_ (lambda (state) (core:transition state '()))]))])))
|
|
||||||
|
|
||||||
(define-syntax-rule (transition/no-state action ...)
|
|
||||||
(transition (void) action ...))
|
|
||||||
|
|
||||||
;; A fresh unification variable, as identifier-syntax.
|
|
||||||
(define-syntax ? (syntax-id-rules () (_ (wild))))
|
|
||||||
|
|
||||||
(define-syntax spawn
|
|
||||||
(lambda (stx)
|
|
||||||
(syntax-parse stx
|
|
||||||
[(_ (~or (~optional (~seq #:pid pid) #:defaults ([pid #'p0]) #:name "#:pid")) ...
|
|
||||||
exp)
|
|
||||||
#`(core:spawn (core:process-spec (lambda (pid) (lambda (k) (k exp))))
|
|
||||||
#f
|
|
||||||
#f)])))
|
|
||||||
|
|
||||||
(define-syntax spawn/continue
|
|
||||||
(lambda (stx)
|
|
||||||
(syntax-parse stx
|
|
||||||
[(_ (~or (~optional (~seq #:pid pid) #:defaults ([pid #'p0]) #:name "#:pid")) ...
|
|
||||||
#:parent parent-state-pattern parent-k-exp
|
|
||||||
#:child exp)
|
|
||||||
#`(core:spawn (core:process-spec (lambda (pid) (lambda (k) (k exp))))
|
|
||||||
(lambda (pid) (match-lambda [parent-state-pattern parent-k-exp]))
|
|
||||||
#f)])))
|
|
||||||
|
|
||||||
(define (name-process n p)
|
|
||||||
(match p
|
|
||||||
[(core:spawn spec parent-k _)
|
|
||||||
(core:spawn spec parent-k n)]))
|
|
||||||
|
|
||||||
(define-syntax yield
|
|
||||||
(lambda (stx)
|
|
||||||
(syntax-case stx ()
|
|
||||||
[(_ state-pattern exp)
|
|
||||||
#'(core:yield (match-lambda [state-pattern exp]))])))
|
|
||||||
|
|
||||||
(define (at-meta-level . preactions)
|
|
||||||
(match preactions
|
|
||||||
[(cons preaction '()) (core:at-meta-level preaction)]
|
|
||||||
[_ (map core:at-meta-level preactions)]))
|
|
||||||
|
|
||||||
(define-syntax spawn-vm
|
|
||||||
(lambda (stx)
|
|
||||||
(syntax-parse stx
|
|
||||||
[(_ (~or (~optional (~seq #:vm-pid vm-pid) #:defaults ([vm-pid #'p0])
|
|
||||||
#:name "#:vm-pid")
|
|
||||||
(~optional (~seq #:boot-pid boot-pid) #:defaults ([boot-pid #'p0])
|
|
||||||
#:name "#:boot-pid")
|
|
||||||
(~optional (~seq #:initial-state initial-state)
|
|
||||||
#:defaults ([initial-state #'(void)])
|
|
||||||
#:name "#:initial-state")
|
|
||||||
(~optional (~seq #:debug-name debug-name)
|
|
||||||
#:defaults ([debug-name #'#f])
|
|
||||||
#:name "#:debug-name"))
|
|
||||||
...
|
|
||||||
exp ...)
|
|
||||||
#`(core:make-nested-vm
|
|
||||||
(lambda (vm-pid)
|
|
||||||
(core:process-spec (lambda (boot-pid)
|
|
||||||
(lambda (k) (k (core:transition initial-state
|
|
||||||
(list exp ...)))))))
|
|
||||||
debug-name)])))
|
|
||||||
|
|
||||||
(define-syntax ground-vm
|
|
||||||
(lambda (stx)
|
|
||||||
(syntax-parse stx
|
|
||||||
[(_ (~or (~optional (~seq #:boot-pid boot-pid) #:defaults ([boot-pid #'p0])
|
|
||||||
#:name "#:boot-pid")
|
|
||||||
(~optional (~seq #:initial-state initial-state)
|
|
||||||
#:defaults ([initial-state #'(void)])
|
|
||||||
#:name "#:initial-state"))
|
|
||||||
...
|
|
||||||
exp ...)
|
|
||||||
#`(core:run-ground-vm
|
|
||||||
(core:process-spec (lambda (boot-pid)
|
|
||||||
(lambda (k) (k (core:transition initial-state
|
|
||||||
(list exp ...)))))))])))
|
|
||||||
|
|
||||||
;;; Local Variables:
|
|
||||||
;;; eval: (put 'sequence-actions 'scheme-indent-function 1)
|
|
||||||
;;; eval: (put 'name-process 'scheme-indent-function 1)
|
|
||||||
;;; eval: (put 'yield 'scheme-indent-function 1)
|
|
||||||
;;; eval: (put 'name-endpoint 'scheme-indent-function 1)
|
|
||||||
;;; eval: (put 'let-fresh 'scheme-indent-function 1)
|
|
||||||
;;; eval: (put 'observe-subscribers 'scheme-indent-function 1)
|
|
||||||
;;; eval: (put 'observe-subscribers/everything 'scheme-indent-function 1)
|
|
||||||
;;; eval: (put 'observe-publishers 'scheme-indent-function 1)
|
|
||||||
;;; eval: (put 'observe-publishers/everything 'scheme-indent-function 1)
|
|
||||||
;;; eval: (put 'publisher 'scheme-indent-function 1)
|
|
||||||
;;; eval: (put 'subscriber 'scheme-indent-function 1)
|
|
||||||
;;; eval: (put 'match-state 'scheme-indent-function 1)
|
|
||||||
;;; eval: (put 'match-orientation 'scheme-indent-function 1)
|
|
||||||
;;; eval: (put 'match-conversation 'scheme-indent-function 1)
|
|
||||||
;;; eval: (put 'match-interest-type 'scheme-indent-function 1)
|
|
||||||
;;; eval: (put 'match-reason 'scheme-indent-function 1)
|
|
||||||
;;; End:
|
|
|
@ -1,105 +0,0 @@
|
||||||
#lang racket/base
|
|
||||||
|
|
||||||
(require racket/match)
|
|
||||||
|
|
||||||
(require (prefix-in core: "../main.rkt"))
|
|
||||||
(require "../sugar.rkt")
|
|
||||||
(require "../vm.rkt")
|
|
||||||
(require "../process.rkt")
|
|
||||||
(require "../quasiqueue.rkt")
|
|
||||||
|
|
||||||
(require "gui.rkt")
|
|
||||||
|
|
||||||
;; (define-type Debugger (All (S) (S -> S)))
|
|
||||||
|
|
||||||
(provide debug)
|
|
||||||
|
|
||||||
;; debug : (All (ParentState) (Spawn ParentState) -> (Spawn ParentState))
|
|
||||||
(define (debug spawn-child)
|
|
||||||
(match-define (core:spawn child-spec parent-k debug-name) spawn-child)
|
|
||||||
(core:spawn
|
|
||||||
(core:process-spec
|
|
||||||
(lambda (pid) ;; TODO: exploit this more in messages etc.
|
|
||||||
(define original-cotransition ((core:process-spec-boot child-spec) pid))
|
|
||||||
;; wrapped-cotransition : (All (R) (All (S) (Transition S) -> R) -> R)
|
|
||||||
(define (wrapped-cotransition k)
|
|
||||||
;; receiver : (All (S) (Transition S) -> R)
|
|
||||||
(define (receiver child-transition)
|
|
||||||
(define d (open-debugger debug-name))
|
|
||||||
(k (wrap-transition d child-transition)))
|
|
||||||
(original-cotransition receiver))
|
|
||||||
wrapped-cotransition))
|
|
||||||
parent-k
|
|
||||||
(list 'debug debug-name)))
|
|
||||||
|
|
||||||
;; wrap-transition : (All (ChildState)
|
|
||||||
;; Debugger
|
|
||||||
;; (Transition ChildState)
|
|
||||||
;; -> (Transition ChildState))
|
|
||||||
(define (wrap-transition d child-transition0)
|
|
||||||
(define child-transition (d child-transition0))
|
|
||||||
(match-define (core:transition child-state child-actions) child-transition)
|
|
||||||
(core:transition child-state (action-tree-map (wrap-action d)
|
|
||||||
child-actions)))
|
|
||||||
|
|
||||||
;; action-tree-map : (All (State) ((Action State) -> (Action State))
|
|
||||||
;; (ActionTree State)
|
|
||||||
;; -> (ActionTree State))
|
|
||||||
(define (action-tree-map f actions)
|
|
||||||
(map f (quasiqueue->list (action-tree->quasiqueue actions))))
|
|
||||||
|
|
||||||
;; wrap-action : (All (ChildState)
|
|
||||||
;; Debugger
|
|
||||||
;; -> ((Action ChildState) -> (Action ChildState)))
|
|
||||||
(define ((wrap-action d) action)
|
|
||||||
(cond
|
|
||||||
[(core:yield? action)
|
|
||||||
(core:yield (wrap-interruptk d (core:yield-k action)))]
|
|
||||||
[(core:at-meta-level? action)
|
|
||||||
(core:at-meta-level (wrap-preaction #t d (core:at-meta-level-preaction action)))]
|
|
||||||
[else
|
|
||||||
(wrap-preaction #f d action)]))
|
|
||||||
|
|
||||||
;; wrap-preaction : (All (ChildState)
|
|
||||||
;; Boolean
|
|
||||||
;; Debugger
|
|
||||||
;; (PreAction ChildState)
|
|
||||||
;; -> (PreAction ChildState))
|
|
||||||
(define (wrap-preaction meta? d preaction)
|
|
||||||
(match preaction
|
|
||||||
[(core:add-endpoint pre-eid role handler)
|
|
||||||
(core:add-endpoint pre-eid role (wrap-handler meta? d handler))]
|
|
||||||
[(core:delete-endpoint pre-eid reason)
|
|
||||||
preaction]
|
|
||||||
[(core:send-message body orientation)
|
|
||||||
preaction]
|
|
||||||
[(core:spawn spec maybe-k child-debug-name)
|
|
||||||
(core:spawn spec (wrap-spawnk d maybe-k) child-debug-name)]
|
|
||||||
[(core:quit pid reason)
|
|
||||||
preaction]))
|
|
||||||
|
|
||||||
;; wrap-interruptk : (All (ChildState)
|
|
||||||
;; Debugger
|
|
||||||
;; (InterruptK ChildState)
|
|
||||||
;; -> (InterruptK ChildState))
|
|
||||||
(define (wrap-interruptk d ik)
|
|
||||||
(lambda (state)
|
|
||||||
(wrap-transition d (ik state))))
|
|
||||||
|
|
||||||
;; wrap-spawnk : (All (ChildState)
|
|
||||||
;; Debugger
|
|
||||||
;; (Option (PID -> (InterruptK ChildState)))
|
|
||||||
;; -> (Option (PID -> (InterruptK ChildState))))
|
|
||||||
(define (wrap-spawnk d maybe-k)
|
|
||||||
(and maybe-k
|
|
||||||
(lambda (child-pid) (wrap-interruptk d (maybe-k child-pid)))))
|
|
||||||
|
|
||||||
;; wrap-handler : (All (ChildState)
|
|
||||||
;; Boolean
|
|
||||||
;; Debugger
|
|
||||||
;; (Handler ChildState)
|
|
||||||
;; -> (Handler ChildState))
|
|
||||||
(define (wrap-handler meta?0 d h)
|
|
||||||
(lambda (event0)
|
|
||||||
(match-define (cons meta? event) (d (cons meta?0 event0)))
|
|
||||||
(wrap-interruptk d (h event))))
|
|
|
@ -1,15 +0,0 @@
|
||||||
#lang racket/base
|
|
||||||
|
|
||||||
(require (for-syntax racket/base))
|
|
||||||
(provide define&provide-dsl-helper-syntaxes)
|
|
||||||
|
|
||||||
(define-syntax-rule (define&provide-dsl-helper-syntaxes context (identifier ...))
|
|
||||||
(begin (provide identifier ...)
|
|
||||||
(define-syntax identifier
|
|
||||||
(lambda (stx)
|
|
||||||
(raise-syntax-error #f
|
|
||||||
(format "Illegal use of ~a outside ~a"
|
|
||||||
'identifier
|
|
||||||
context)
|
|
||||||
stx)))
|
|
||||||
...))
|
|
|
@ -1,52 +0,0 @@
|
||||||
#lang racket/base
|
|
||||||
;; Copyright (C) 2012 Tony Garnock-Jones <tonygarnockjones@gmail.com>
|
|
||||||
|
|
||||||
;; Pretty hex dump output of a Bytes.
|
|
||||||
|
|
||||||
(provide dump-bytes!)
|
|
||||||
|
|
||||||
;; Exact Exact -> String
|
|
||||||
;; Returns the "0"-padded, width-digit hex representation of n
|
|
||||||
(define (hex width n)
|
|
||||||
(define s (number->string n 16))
|
|
||||||
(define slen (string-length s))
|
|
||||||
(cond
|
|
||||||
((< slen width) (string-append (make-string (- width slen) #\0) s))
|
|
||||||
((= slen width) s)
|
|
||||||
((> slen width) (substring s 0 width))))
|
|
||||||
|
|
||||||
;; Bytes Exact -> Void
|
|
||||||
;; Prints a pretty hex/ASCII dump of bs on (current-output-port).
|
|
||||||
(define (dump-bytes! bs [requested-count (bytes-length bs)] #:base [baseaddr 0])
|
|
||||||
(define count (min requested-count (bytes-length bs)))
|
|
||||||
(define clipped (subbytes bs 0 count))
|
|
||||||
(define (dump-hex i)
|
|
||||||
(if (< i count)
|
|
||||||
(display (hex 2 (bytes-ref clipped i)))
|
|
||||||
(display " "))
|
|
||||||
(display #\space))
|
|
||||||
(define (dump-char i)
|
|
||||||
(if (< i count)
|
|
||||||
(let ((ch (bytes-ref clipped i)))
|
|
||||||
(if (<= 32 ch 127)
|
|
||||||
(display (integer->char ch))
|
|
||||||
(display #\.)))
|
|
||||||
(display #\space)))
|
|
||||||
(define (for-each-between f low high)
|
|
||||||
(do ((i low (+ i 1)))
|
|
||||||
((= i high))
|
|
||||||
(f i)))
|
|
||||||
(define (dump-line i)
|
|
||||||
(display (hex 8 (+ i baseaddr)))
|
|
||||||
(display #\space)
|
|
||||||
(for-each-between dump-hex i (+ i 8))
|
|
||||||
(display ": ")
|
|
||||||
(for-each-between dump-hex (+ i 8) (+ i 16))
|
|
||||||
(display #\space)
|
|
||||||
(for-each-between dump-char i (+ i 8))
|
|
||||||
(display " : ")
|
|
||||||
(for-each-between dump-char (+ i 8) (+ i 16))
|
|
||||||
(newline))
|
|
||||||
(do ((i 0 (+ i 16)))
|
|
||||||
((>= i count))
|
|
||||||
(dump-line i)))
|
|
416
support/gui.rkt
416
support/gui.rkt
|
@ -1,416 +0,0 @@
|
||||||
#lang racket/base
|
|
||||||
|
|
||||||
(require racket/set)
|
|
||||||
(require racket/match)
|
|
||||||
(require racket/class)
|
|
||||||
(require racket/async-channel)
|
|
||||||
(require racket/gui/base)
|
|
||||||
(require racket/date)
|
|
||||||
(require racket/format)
|
|
||||||
(require racket/math)
|
|
||||||
|
|
||||||
(require images/icons/control)
|
|
||||||
(require images/icons/arrow)
|
|
||||||
(require images/icons/symbol)
|
|
||||||
(require images/icons/misc)
|
|
||||||
(require images/icons/style)
|
|
||||||
|
|
||||||
(require data/queue)
|
|
||||||
|
|
||||||
(require racket/pretty)
|
|
||||||
|
|
||||||
(require (prefix-in core: "../structs.rkt")
|
|
||||||
(prefix-in core: "../vm.rkt"))
|
|
||||||
|
|
||||||
(provide open-debugger)
|
|
||||||
|
|
||||||
;; Frame
|
|
||||||
;; Toolbar
|
|
||||||
;; Rewind one step - moves without executing
|
|
||||||
;; Fast-forward one step - moves without executing
|
|
||||||
;; --
|
|
||||||
;; Stop
|
|
||||||
;; Run one step
|
|
||||||
;; Play
|
|
||||||
;; --
|
|
||||||
;; Select history depth
|
|
||||||
;; --
|
|
||||||
;; Kill this process
|
|
||||||
;; State display
|
|
||||||
;; If the state is (vm?), special display; permits spawning debuggers on nested processes
|
|
||||||
;; Endpoints display
|
|
||||||
;; Shows ID and role
|
|
||||||
;; Permits deletion of endpoint
|
|
||||||
;; Permits interaction with endpoint??
|
|
||||||
;; Trace display
|
|
||||||
;; Selection of a row rewinds to that point
|
|
||||||
|
|
||||||
(struct historical-moment (alive? state endpoints) #:transparent)
|
|
||||||
|
|
||||||
(define (open-debugger name)
|
|
||||||
(define to-debugger (make-channel))
|
|
||||||
(define from-debugger (make-channel))
|
|
||||||
(parameterize ((current-eventspace (make-eventspace)))
|
|
||||||
(new debugger%
|
|
||||||
[name name]
|
|
||||||
[from-vm to-debugger]
|
|
||||||
[to-vm from-debugger]))
|
|
||||||
(lambda (v)
|
|
||||||
(channel-put to-debugger v)
|
|
||||||
(channel-get from-debugger)))
|
|
||||||
|
|
||||||
(define sane-tab-panel%
|
|
||||||
(class tab-panel%
|
|
||||||
(super-new)
|
|
||||||
(define/override (place-children l width height)
|
|
||||||
(for/list [(child-spec (in-list l))]
|
|
||||||
(match-define (list min-w min-h v-stretch? h-stretch?) child-spec)
|
|
||||||
(list 0
|
|
||||||
0
|
|
||||||
(if h-stretch? width min-w)
|
|
||||||
(if v-stretch? height min-h))))))
|
|
||||||
|
|
||||||
(define (string->label-string s)
|
|
||||||
;; Per documentation for (label-string?), a label string "is a
|
|
||||||
;; string whose length is less than or equal to 200."
|
|
||||||
(if (> (string-length s) 200)
|
|
||||||
(string-append (substring s 0 196) " ...")
|
|
||||||
s))
|
|
||||||
|
|
||||||
(define debugger%
|
|
||||||
(class object%
|
|
||||||
|
|
||||||
(init-field name)
|
|
||||||
(init-field from-vm)
|
|
||||||
(init-field to-vm)
|
|
||||||
|
|
||||||
(define mutex (make-semaphore 1))
|
|
||||||
(define stepping? #t)
|
|
||||||
(define k-queue (make-queue))
|
|
||||||
|
|
||||||
(define (reply-to-vm reply)
|
|
||||||
(call-with-semaphore mutex
|
|
||||||
(lambda () (if stepping?
|
|
||||||
(channel-put to-vm reply)
|
|
||||||
(enqueue! k-queue reply)))))
|
|
||||||
|
|
||||||
(define current-historical-moment (historical-moment #t (void) '()))
|
|
||||||
(define displayed-endpoints '())
|
|
||||||
(define booted? #f)
|
|
||||||
|
|
||||||
(define frame (new frame%
|
|
||||||
[label (format "~a" name)]
|
|
||||||
[width 480]
|
|
||||||
[height 700]))
|
|
||||||
|
|
||||||
(define menu-bar (new menu-bar% [parent frame]))
|
|
||||||
(define edit-menu (new menu% [label "Edit"] [parent menu-bar]))
|
|
||||||
(append-editor-operation-menu-items edit-menu #f)
|
|
||||||
|
|
||||||
(define state-panel (new sane-tab-panel%
|
|
||||||
[parent frame]
|
|
||||||
[choices '("Process State")]
|
|
||||||
[callback (lambda (p e) (select-state-tab))]))
|
|
||||||
|
|
||||||
(define endpoints (new list-box%
|
|
||||||
[style '(single column-headers)]
|
|
||||||
[label #f]
|
|
||||||
[choices '()]
|
|
||||||
[parent frame]
|
|
||||||
[columns '("ID" "" "" "" "Topic")]))
|
|
||||||
|
|
||||||
(define events (new list-box%
|
|
||||||
[style '(single column-headers)]
|
|
||||||
[callback (lambda (lb e)
|
|
||||||
(define sel (or (send lb get-selection)
|
|
||||||
(- (send lb get-number) 1)))
|
|
||||||
(define m (and sel (send lb get-data sel)))
|
|
||||||
(when m (select-historical-moment m)))]
|
|
||||||
[label #f]
|
|
||||||
[choices '()]
|
|
||||||
[parent frame]
|
|
||||||
[columns '("Time" "Dir" "Type" "Detail")]))
|
|
||||||
|
|
||||||
(define FIXED-COLUMN-WIDTH 40)
|
|
||||||
(send endpoints set-column-width 1 FIXED-COLUMN-WIDTH FIXED-COLUMN-WIDTH FIXED-COLUMN-WIDTH)
|
|
||||||
(send endpoints set-column-width 2 FIXED-COLUMN-WIDTH FIXED-COLUMN-WIDTH FIXED-COLUMN-WIDTH)
|
|
||||||
(send endpoints set-column-width 3 FIXED-COLUMN-WIDTH FIXED-COLUMN-WIDTH FIXED-COLUMN-WIDTH)
|
|
||||||
|
|
||||||
(send events set-column-width 1 FIXED-COLUMN-WIDTH FIXED-COLUMN-WIDTH FIXED-COLUMN-WIDTH)
|
|
||||||
|
|
||||||
(define toolbar (new horizontal-pane%
|
|
||||||
[parent frame]
|
|
||||||
[stretchable-height #f]
|
|
||||||
[alignment '(right center)]))
|
|
||||||
|
|
||||||
(define (toolbar-button label [handler void])
|
|
||||||
(new button%
|
|
||||||
[label label]
|
|
||||||
[min-width 32]
|
|
||||||
[parent toolbar]
|
|
||||||
[callback handler]))
|
|
||||||
|
|
||||||
(define (toolbar-spacer)
|
|
||||||
(new pane% [parent toolbar] [min-width 16] [stretchable-width #f]))
|
|
||||||
|
|
||||||
;; (toolbar-button (left-over-arrow-icon #:color syntax-icon-color))
|
|
||||||
;; (toolbar-button (right-over-arrow-icon #:color syntax-icon-color))
|
|
||||||
;; (toolbar-spacer)
|
|
||||||
|
|
||||||
(define pause-button
|
|
||||||
(toolbar-button (pause-icon #:color halt-icon-color)
|
|
||||||
(lambda (b e)
|
|
||||||
(send pause-button enable #f)
|
|
||||||
(send play-button enable #t)
|
|
||||||
(send step-button enable #t)
|
|
||||||
(call-with-semaphore
|
|
||||||
mutex
|
|
||||||
(lambda ()
|
|
||||||
(set! stepping? #f))))))
|
|
||||||
(define play-button
|
|
||||||
(toolbar-button (play-icon #:color run-icon-color)
|
|
||||||
(lambda (b e)
|
|
||||||
(send pause-button enable #t)
|
|
||||||
(send play-button enable #f)
|
|
||||||
(send step-button enable #f)
|
|
||||||
(call-with-semaphore
|
|
||||||
mutex
|
|
||||||
(lambda ()
|
|
||||||
(set! stepping? #t)
|
|
||||||
(when (non-empty-queue? k-queue)
|
|
||||||
(channel-put to-vm (dequeue! k-queue))))))))
|
|
||||||
(toolbar-spacer)
|
|
||||||
(define step-button
|
|
||||||
(toolbar-button (step-icon #:color run-icon-color)
|
|
||||||
(lambda (b e)
|
|
||||||
(call-with-semaphore
|
|
||||||
mutex
|
|
||||||
(lambda ()
|
|
||||||
(when (non-empty-queue? k-queue)
|
|
||||||
(channel-put to-vm (dequeue! k-queue))))))))
|
|
||||||
|
|
||||||
(send play-button enable #f)
|
|
||||||
(send step-button enable #f)
|
|
||||||
|
|
||||||
;; (toolbar-spacer)
|
|
||||||
;; (toolbar-button "Settings...")
|
|
||||||
;; (toolbar-spacer)
|
|
||||||
;; (toolbar-button (stop-sign-icon))
|
|
||||||
|
|
||||||
(define status-indicator
|
|
||||||
(new canvas%
|
|
||||||
[parent toolbar]
|
|
||||||
[min-width 32]
|
|
||||||
[min-height 32]
|
|
||||||
[stretchable-width #f]
|
|
||||||
[style '(transparent no-focus)]
|
|
||||||
[paint-callback (lambda (c dc)
|
|
||||||
(define mx (/ (send c get-width) 2))
|
|
||||||
(define my (/ (send c get-height) 2))
|
|
||||||
(define r (/ (min mx my) 2))
|
|
||||||
(send dc set-brush
|
|
||||||
(if (historical-moment-alive? current-historical-moment)
|
|
||||||
"green"
|
|
||||||
"red")
|
|
||||||
'solid)
|
|
||||||
(send dc draw-ellipse (- mx r) (- my r) (* r 2) (* r 2)))]))
|
|
||||||
|
|
||||||
(define state-text (new text%))
|
|
||||||
(define state-canvas (new editor-canvas%
|
|
||||||
[parent state-panel]
|
|
||||||
[editor state-text]
|
|
||||||
[label "State"]))
|
|
||||||
|
|
||||||
(define vm-display (new list-box%
|
|
||||||
[style '(single column-headers)]
|
|
||||||
[label #f]
|
|
||||||
[choices '()]
|
|
||||||
[parent state-panel]
|
|
||||||
[columns '("PID" "#Endpoints" "#MetaEndpoints" "Name")]))
|
|
||||||
(send vm-display show #f)
|
|
||||||
|
|
||||||
(define (select-historical-moment m)
|
|
||||||
(match-define (historical-moment alive? state new-endpoints) m)
|
|
||||||
|
|
||||||
(when (not (equal? displayed-endpoints new-endpoints))
|
|
||||||
(send endpoints clear)
|
|
||||||
(for [(ep (in-list new-endpoints))]
|
|
||||||
(match-define (list pre-eid meta? (core:role orientation topic interest-type)) ep)
|
|
||||||
(define n (send endpoints get-number))
|
|
||||||
(send endpoints append (~v pre-eid))
|
|
||||||
(send endpoints set-string n (if meta? "Meta" "") 1)
|
|
||||||
(send endpoints set-string n (case orientation
|
|
||||||
[(publisher) "Pub"]
|
|
||||||
[(subscriber) "Sub"]) 2)
|
|
||||||
(send endpoints set-string n (case interest-type
|
|
||||||
[(participant) ""]
|
|
||||||
[(observer) "Obs"]
|
|
||||||
[(everything) "***"]) 3)
|
|
||||||
(send endpoints set-string n (~v topic) 4))
|
|
||||||
(set! displayed-endpoints new-endpoints))
|
|
||||||
|
|
||||||
(send state-canvas set-canvas-background
|
|
||||||
(if alive?
|
|
||||||
(make-color #xff #xff #xff)
|
|
||||||
(make-color #xff #xd0 #xd0)))
|
|
||||||
|
|
||||||
(send status-indicator refresh)
|
|
||||||
|
|
||||||
(send state-text erase)
|
|
||||||
(send state-text insert (pretty-format state))
|
|
||||||
|
|
||||||
(when (core:vm? state)
|
|
||||||
(refresh-vm-display state)
|
|
||||||
(when (= 1 (send state-panel get-number))
|
|
||||||
(send state-panel append "VM State")
|
|
||||||
(send state-panel set-selection 1)
|
|
||||||
(select-state-tab))))
|
|
||||||
|
|
||||||
(define (refresh-vm-display v)
|
|
||||||
;; (define procs (sort (hash->list (core:vm-processes v)) < #:key car))
|
|
||||||
(send vm-display clear)
|
|
||||||
;; (for [(entry (in-list procs))]
|
|
||||||
;; (match-define (cons pid wp) entry)
|
|
||||||
;; ;;(wp (lambda (p) (displayln `(P ,p))))
|
|
||||||
;; (displayln (cons pid wp)))
|
|
||||||
)
|
|
||||||
|
|
||||||
(define (select-state-tab)
|
|
||||||
(define selection (send state-panel get-selection))
|
|
||||||
(send state-canvas show (= selection 0))
|
|
||||||
(send vm-display show (= selection 1)))
|
|
||||||
|
|
||||||
(define controller-thread
|
|
||||||
(thread
|
|
||||||
(lambda ()
|
|
||||||
(controller-thread-loop))))
|
|
||||||
|
|
||||||
(define (current-timestamp)
|
|
||||||
(define (p n w) (~a (exact-truncate n) #:width w #:align 'right #:pad-string "0"))
|
|
||||||
(define d (current-date))
|
|
||||||
(format "~a:~a:~a.~a ~a-~a-~a"
|
|
||||||
(p (date-hour d) 2)
|
|
||||||
(p (date-minute d) 2)
|
|
||||||
(p (date-second d) 2)
|
|
||||||
(p (/ (date*-nanosecond d) 1000000.0) 3)
|
|
||||||
(date-year d)
|
|
||||||
(p (date-month d) 2)
|
|
||||||
(p (date-day d) 2)))
|
|
||||||
|
|
||||||
(define (record-event! stamp dir type detail)
|
|
||||||
(define n (send events get-number))
|
|
||||||
(send events append stamp)
|
|
||||||
(send events set-data n current-historical-moment)
|
|
||||||
(send events set-string n dir 1)
|
|
||||||
(send events set-string n type 2)
|
|
||||||
(send events set-string n (string->label-string (~a detail)) 3)
|
|
||||||
(define current-selection (send events get-selection))
|
|
||||||
(when (or (not current-selection) (= current-selection (- n 1)))
|
|
||||||
(send events set-first-visible-item n)
|
|
||||||
(send events set-selection n)
|
|
||||||
(select-historical-moment current-historical-moment)))
|
|
||||||
|
|
||||||
(define (format-action action)
|
|
||||||
(cond
|
|
||||||
[(core:yield? action)
|
|
||||||
(values "Yield" "")]
|
|
||||||
[(core:at-meta-level? action)
|
|
||||||
(format-preaction "Meta" (core:at-meta-level-preaction action))]
|
|
||||||
[else
|
|
||||||
(format-preaction "" action)]))
|
|
||||||
|
|
||||||
(define (format-preaction layer preaction)
|
|
||||||
(define-values (type detail)
|
|
||||||
(match preaction
|
|
||||||
[(core:add-endpoint pre-eid role handler)
|
|
||||||
(values "Sub" (string-append (format-role role) " " (~a pre-eid)))]
|
|
||||||
[(core:delete-endpoint pre-eid reason)
|
|
||||||
(values "Unsub" (format "~a ~v" pre-eid reason))]
|
|
||||||
[(core:send-message body 'publisher)
|
|
||||||
(values "Send" (~v body))]
|
|
||||||
[(core:send-message body 'subscriber)
|
|
||||||
(values "Feedback" (~v body))]
|
|
||||||
[(core:spawn spec maybe-k child-debug-name)
|
|
||||||
(values "Spawn" (~v child-debug-name))]
|
|
||||||
[(core:quit #f reason)
|
|
||||||
(values "Exit" (~v reason))]
|
|
||||||
[(core:quit pid reason)
|
|
||||||
(values "Kill" (format "~a ~v" pid reason))]))
|
|
||||||
(values (string-append layer type) detail))
|
|
||||||
|
|
||||||
(define (format-role r)
|
|
||||||
(match-define (core:role orientation topic interest-type) r)
|
|
||||||
(format "~a/~a ~v"
|
|
||||||
(string-ref (symbol->string orientation) 0)
|
|
||||||
(string-ref (symbol->string interest-type) 0)
|
|
||||||
topic))
|
|
||||||
|
|
||||||
(define (apply-action! a)
|
|
||||||
(cond
|
|
||||||
[(core:yield? a) (void)]
|
|
||||||
[(core:at-meta-level? a) (apply-preaction! #t (core:at-meta-level-preaction a))]
|
|
||||||
[else (apply-preaction! #f a)]))
|
|
||||||
|
|
||||||
(define (apply-preaction! meta? p)
|
|
||||||
(match p
|
|
||||||
[(core:quit #f reason)
|
|
||||||
(set! current-historical-moment
|
|
||||||
(struct-copy historical-moment current-historical-moment
|
|
||||||
[alive? #f]))]
|
|
||||||
[(core:add-endpoint pre-eid role handler)
|
|
||||||
(set! current-historical-moment
|
|
||||||
(struct-copy historical-moment current-historical-moment
|
|
||||||
[endpoints (append (filter (lambda (e) (not (equal? (car e) pre-eid)))
|
|
||||||
(historical-moment-endpoints
|
|
||||||
current-historical-moment))
|
|
||||||
(list (list pre-eid meta? role)))]))]
|
|
||||||
[(core:delete-endpoint pre-eid reason)
|
|
||||||
(set! current-historical-moment
|
|
||||||
(struct-copy historical-moment current-historical-moment
|
|
||||||
[endpoints (filter (lambda (e) (not (equal? (car e) pre-eid)))
|
|
||||||
(historical-moment-endpoints
|
|
||||||
current-historical-moment))]))]
|
|
||||||
[_ (void)]))
|
|
||||||
|
|
||||||
(define (handle-from-vm x)
|
|
||||||
(define now (current-timestamp))
|
|
||||||
(match x
|
|
||||||
[(core:transition state actions)
|
|
||||||
(when (or (not booted?)
|
|
||||||
(not (equal? state (historical-moment-state current-historical-moment))))
|
|
||||||
(set! booted? #t)
|
|
||||||
(set! current-historical-moment
|
|
||||||
(struct-copy historical-moment current-historical-moment [state state]))
|
|
||||||
(record-event! now "Txn" "State" (~v state)))
|
|
||||||
(let loop ((a actions))
|
|
||||||
(cond
|
|
||||||
[(pair? a) (loop (car a)) (loop (cdr a))]
|
|
||||||
[(or (null? a) (eq? a #f) (void? a)) (void)]
|
|
||||||
[else (define-values (type detail) (format-action a))
|
|
||||||
(apply-action! a)
|
|
||||||
(record-event! now "Act" type detail)]))
|
|
||||||
(reply-to-vm x)]
|
|
||||||
[(cons meta? e)
|
|
||||||
(define prefix (if meta? "Meta" ""))
|
|
||||||
(match e
|
|
||||||
[(core:presence-event role)
|
|
||||||
(record-event! now "Evt" (string-append prefix "Presence") (format-role role))]
|
|
||||||
[(core:absence-event role reason)
|
|
||||||
(record-event! now "Evt" (string-append prefix "Absence")
|
|
||||||
(string-append (format-role role) " " (~v reason)))]
|
|
||||||
[(core:message-event _ message)
|
|
||||||
(record-event! now "Evt" (string-append prefix "Recv") (~v message))])
|
|
||||||
(reply-to-vm x)]))
|
|
||||||
|
|
||||||
(define (controller-thread-loop)
|
|
||||||
(sync (handle-evt from-vm
|
|
||||||
(lambda (x)
|
|
||||||
(queue-callback (lambda () (handle-from-vm x)))
|
|
||||||
(controller-thread-loop)))))
|
|
||||||
|
|
||||||
(super-new)
|
|
||||||
|
|
||||||
(select-historical-moment current-historical-moment)
|
|
||||||
|
|
||||||
(send frame show #t)
|
|
||||||
))
|
|
|
@ -1,30 +0,0 @@
|
||||||
#lang racket/base
|
|
||||||
|
|
||||||
(require "../sugar.rkt")
|
|
||||||
|
|
||||||
(provide generic-spy)
|
|
||||||
|
|
||||||
;; generic-spy : (All (ParentState) Any -> (Spawn ParentState))
|
|
||||||
(define (generic-spy label)
|
|
||||||
(name-process `(generic-spy ,label)
|
|
||||||
(spawn (transition (void)
|
|
||||||
(observe-publishers (wild)
|
|
||||||
(match-orientation orientation
|
|
||||||
(match-conversation topic
|
|
||||||
(match-interest-type interest
|
|
||||||
(match-reason reason
|
|
||||||
(on-presence (begin (write `(,label ENTER (,orientation ,topic ,interest)))
|
|
||||||
(newline)
|
|
||||||
(flush-output)
|
|
||||||
'()))
|
|
||||||
(on-absence (begin (write `(,label EXIT (,orientation ,topic ,interest)))
|
|
||||||
(newline)
|
|
||||||
(display reason)
|
|
||||||
(newline)
|
|
||||||
(flush-output)
|
|
||||||
'()))
|
|
||||||
(on-message
|
|
||||||
[p (begin (write `(,label MSG ,p))
|
|
||||||
(newline)
|
|
||||||
(flush-output)
|
|
||||||
'())]))))))))))
|
|
|
@ -1,14 +0,0 @@
|
||||||
#lang racket/base
|
|
||||||
|
|
||||||
(require "struct-map.rkt")
|
|
||||||
(require rackunit)
|
|
||||||
(provide (struct-out foo))
|
|
||||||
|
|
||||||
(struct foo (bar zot)
|
|
||||||
#:transparent
|
|
||||||
#:property prop:struct-map (lambda (f seed x)
|
|
||||||
(define-values (bar* seed*) (f (foo-bar x) seed))
|
|
||||||
(values (foo bar* (foo-zot x)) seed)))
|
|
||||||
|
|
||||||
(check-equal? (struct-map (lambda (x) (list '! x)) (foo 123 234))
|
|
||||||
(foo (list '! 123) 234))
|
|
297
unify.rkt
297
unify.rkt
|
@ -1,297 +0,0 @@
|
||||||
#lang racket/base
|
|
||||||
|
|
||||||
(require racket/set)
|
|
||||||
(require racket/match)
|
|
||||||
(require (only-in racket/class object?))
|
|
||||||
(require "struct-map.rkt")
|
|
||||||
|
|
||||||
(provide (struct-out variable)
|
|
||||||
(struct-out canonical-variable)
|
|
||||||
wild
|
|
||||||
wild?
|
|
||||||
non-wild?
|
|
||||||
ground?
|
|
||||||
variables-in
|
|
||||||
unify
|
|
||||||
unify/env
|
|
||||||
unify/vars
|
|
||||||
unify-match/vars
|
|
||||||
freshen
|
|
||||||
canonicalize
|
|
||||||
mgu-freshen
|
|
||||||
mgu-canonical
|
|
||||||
apply-subst
|
|
||||||
specialization?
|
|
||||||
upper-case-symbols->variables
|
|
||||||
upper-case-symbols->canonical)
|
|
||||||
|
|
||||||
;; A Subst is a Maybe<AList<Variable,Any>>.
|
|
||||||
;; TODO: semantics
|
|
||||||
|
|
||||||
;; Compared by eq?, not equal?. In particular, info is not involved in
|
|
||||||
;; equivalence.
|
|
||||||
(struct variable (info)
|
|
||||||
#:property prop:custom-write
|
|
||||||
(lambda (v port mode)
|
|
||||||
(display "?" port)
|
|
||||||
(write (variable-info v) port)))
|
|
||||||
|
|
||||||
;; Compared by equal?, not eq?. The number is a part of the
|
|
||||||
;; appropriate equivalence relation for canonical-variables.
|
|
||||||
(struct canonical-variable (index) #:transparent
|
|
||||||
#:property prop:custom-write
|
|
||||||
(lambda (v port mode)
|
|
||||||
(display "?!" port)
|
|
||||||
(write (canonical-variable-index v) port)))
|
|
||||||
|
|
||||||
;; -> Variable
|
|
||||||
;; Create a fresh (and hence unconstrained) variable.
|
|
||||||
(define (wild [base-name '_])
|
|
||||||
(variable (gensym base-name)))
|
|
||||||
|
|
||||||
;; Any -> Boolean
|
|
||||||
;; True iff the argument is a variable or canonical-variable.
|
|
||||||
(define (wild? x)
|
|
||||||
(or (variable? x) (canonical-variable? x)))
|
|
||||||
|
|
||||||
;; Any -> Boolean
|
|
||||||
;; True iff the argument is neither a variable nor a canonical-variable.
|
|
||||||
(define (non-wild? x)
|
|
||||||
(not (wild? x)))
|
|
||||||
|
|
||||||
;; Any -> Boolean
|
|
||||||
;; Racket objects are structures, so we reject them explicitly for
|
|
||||||
;; now, leaving them opaque to unification.
|
|
||||||
(define (non-object-struct? x)
|
|
||||||
(and (struct? x)
|
|
||||||
(not (object? x))))
|
|
||||||
|
|
||||||
;; Any -> Set<Variable>
|
|
||||||
(define (variables-in x)
|
|
||||||
(let walk ((x x) (acc (set)))
|
|
||||||
(cond
|
|
||||||
[(wild? x) (set-add acc x)]
|
|
||||||
[(pair? x) (walk (car x) (walk (cdr x) acc))]
|
|
||||||
[(vector? x) (foldl walk acc (vector->list x))]
|
|
||||||
[(non-object-struct? x) (walk (struct->vector x #f) acc)]
|
|
||||||
[else acc])))
|
|
||||||
|
|
||||||
;; Any -> Boolean
|
|
||||||
;; True iff the term is completely ground, that is has no variables or
|
|
||||||
;; canonical-variables in it.
|
|
||||||
(define (ground? x)
|
|
||||||
(let walk ((x x))
|
|
||||||
(cond
|
|
||||||
[(wild? x) #f]
|
|
||||||
[(pair? x) (and (walk (car x)) (walk (cdr x)))]
|
|
||||||
[(vector? x) (andmap walk (vector->list x))]
|
|
||||||
[(non-object-struct? x) (walk (struct->vector x #f))]
|
|
||||||
[else #t])))
|
|
||||||
|
|
||||||
;; Variable Any -> Boolean
|
|
||||||
(define (occurs? var val)
|
|
||||||
(let walk ((x val))
|
|
||||||
(cond
|
|
||||||
[(eq? var x) #t]
|
|
||||||
[(pair? x) (or (walk (car x)) (walk (cdr x)))]
|
|
||||||
[(vector? x) (ormap walk (vector->list x))]
|
|
||||||
[(non-object-struct? x) (walk (struct->vector x #f))]
|
|
||||||
[else #f])))
|
|
||||||
|
|
||||||
;; Variable Any Subst -> Subst
|
|
||||||
(define (extend-subst var val env)
|
|
||||||
(cond
|
|
||||||
[(eq? var val)
|
|
||||||
;; Avoid trivial tautologies. Less trivial ones are not detected,
|
|
||||||
;; but are harmless.
|
|
||||||
env]
|
|
||||||
[(occurs? var val)
|
|
||||||
;; Occurs check.
|
|
||||||
#f]
|
|
||||||
[else
|
|
||||||
(cons (cons var val) env)]))
|
|
||||||
|
|
||||||
;; Any Subst Set<Variable> -> Any
|
|
||||||
(define (chase x env seen)
|
|
||||||
(if (variable? x)
|
|
||||||
(cond [(set-member? seen x) x]
|
|
||||||
[(assq x env) => (lambda (cell) (chase (cdr cell) env (set-add seen x)))]
|
|
||||||
[else x])
|
|
||||||
x))
|
|
||||||
|
|
||||||
;; Any Any -> Subst
|
|
||||||
(define (unify a b)
|
|
||||||
(unify/env a b '()))
|
|
||||||
|
|
||||||
;; Any Any Subst -> Subst
|
|
||||||
(define (unify/env a0 b0 env)
|
|
||||||
(let walk ((a0 a0) (b0 b0) (env env))
|
|
||||||
(and env
|
|
||||||
(let ((a (chase a0 env (set)))
|
|
||||||
(b (chase b0 env (set))))
|
|
||||||
(cond
|
|
||||||
[(variable? a) (extend-subst a b env)]
|
|
||||||
[(variable? b) (extend-subst b a env)]
|
|
||||||
[(and (pair? a) (pair? b))
|
|
||||||
(walk (car a) (car b) (walk (cdr a) (cdr b) env))]
|
|
||||||
[(and (vector? a) (vector? b) (= (vector-length a) (vector-length b)))
|
|
||||||
(for/fold ([env env]) ([ea a] [eb b]) (walk ea eb env))]
|
|
||||||
[(and (non-object-struct? a) (non-object-struct? b))
|
|
||||||
(walk (struct->vector a #f) (struct->vector b #f) env)]
|
|
||||||
[else (and (equal? a b) env)])))))
|
|
||||||
|
|
||||||
;; Any -> (values Any AList<Symbol,Variable>)
|
|
||||||
;; Converts upper-case symbols to variables, making sure that
|
|
||||||
;; eq? symbols map to eq? variables.
|
|
||||||
(define (upper-case-symbols->variables x)
|
|
||||||
(let walk ((x x) (env '()))
|
|
||||||
(cond
|
|
||||||
[(upper-case-symbol? x)
|
|
||||||
(cond [(assq x env) => (lambda (cell) (values (cdr cell) env))]
|
|
||||||
[else (let ((v (variable x))) (values v (cons (cons x v) env)))])]
|
|
||||||
[(pair? x)
|
|
||||||
(define-values (a env1) (walk (car x) env))
|
|
||||||
(define-values (d env2) (walk (cdr x) env1))
|
|
||||||
(values (cons a d) env2)]
|
|
||||||
[(vector? x)
|
|
||||||
(define result (make-vector (vector-length x)))
|
|
||||||
(values result (for/fold ([env env]) ([i (vector-length x)])
|
|
||||||
(define-values (val env1) (walk (vector-ref x i) env))
|
|
||||||
(vector-set! result i val)
|
|
||||||
env1))]
|
|
||||||
[(non-object-struct? x) (struct-map/accumulator walk env x)]
|
|
||||||
[else (values x env)])))
|
|
||||||
|
|
||||||
;; Any -> Any
|
|
||||||
(define (upper-case-symbols->canonical t)
|
|
||||||
(define env (make-hash)) ;; cheeky use of mutation
|
|
||||||
(let walk ((t t))
|
|
||||||
(cond
|
|
||||||
[(or (upper-case-symbol? t) (wild? t))
|
|
||||||
(cond [(hash-ref env t #f)]
|
|
||||||
[else (define v (canonical-variable (hash-count env))) (hash-set! env t v) v])]
|
|
||||||
[(pair? t) (cons (walk (car t)) (walk (cdr t)))]
|
|
||||||
[(vector? t) (list->vector (map walk (vector->list t)))]
|
|
||||||
[(non-object-struct? t) (struct-map walk t)]
|
|
||||||
[else t])))
|
|
||||||
|
|
||||||
;; Any -> Boolean
|
|
||||||
(define (upper-case-symbol? x)
|
|
||||||
(and (symbol? x)
|
|
||||||
(let ((name (symbol->string x)))
|
|
||||||
(and (positive? (string-length name))
|
|
||||||
(char-upper-case? (string-ref name 0))))))
|
|
||||||
|
|
||||||
;; AList<A,B> -> AList<B,A>
|
|
||||||
(define (flip-env env)
|
|
||||||
(map (lambda (x) (cons (cdr x) (car x))) env))
|
|
||||||
|
|
||||||
;; Any Any -> Subst
|
|
||||||
;; Like unify after upper-case-symbols->variables on both arguments.
|
|
||||||
(define (unify/vars a b)
|
|
||||||
(define-values (processed env) (upper-case-symbols->variables (cons a b)))
|
|
||||||
(define s (unify (car processed) (cdr processed)))
|
|
||||||
(and s (apply-subst s env)))
|
|
||||||
|
|
||||||
;; Any Any -> Subst
|
|
||||||
;; Like unify-match after upper-case-symbols->variables on both
|
|
||||||
;; arguments, extracting bindings only from the first argument.
|
|
||||||
(define (unify-match/vars a b)
|
|
||||||
(define-values (pa a-env) (upper-case-symbols->variables a))
|
|
||||||
(define-values (pb b-env) (upper-case-symbols->variables b))
|
|
||||||
(define s (unify pa pb))
|
|
||||||
(and s (apply-subst s a-env)))
|
|
||||||
|
|
||||||
;; Utility used by freshen and canonicalize below.
|
|
||||||
;; Must visit the term in the order specified by canonicalize
|
|
||||||
;; below. Here we rely both upon Racket's left-to-right evaluation
|
|
||||||
;; order and upon defined struct-mappers traversing their arguments in
|
|
||||||
;; some deterministic order.
|
|
||||||
(define (freshen* t var-handler canon-handler)
|
|
||||||
(define env (make-hash)) ;; cheeky use of mutation
|
|
||||||
(let walk ((t t))
|
|
||||||
(cond
|
|
||||||
[(wild? t)
|
|
||||||
(cond [(hash-ref env t #f)]
|
|
||||||
[else (define v ((if (canonical-variable? t) canon-handler var-handler) t env))
|
|
||||||
(hash-set! env t v)
|
|
||||||
v])]
|
|
||||||
[(pair? t) (cons (walk (car t)) (walk (cdr t)))]
|
|
||||||
[(vector? t) (list->vector (map walk (vector->list t)))]
|
|
||||||
[(non-object-struct? t) (struct-map walk t)]
|
|
||||||
[else t])))
|
|
||||||
|
|
||||||
;; Any -> Any
|
|
||||||
;;
|
|
||||||
;; Freshens a term by substituting out variables in the term with
|
|
||||||
;; fresh variables to produce an arbitrary member of the term's
|
|
||||||
;; alpha-equivalence-class that shares no variables with the original.
|
|
||||||
;;
|
|
||||||
;; Treats canonical-variables just like regular ones, freshening them
|
|
||||||
;; with new ordinary (non-canonical) variables.
|
|
||||||
(define (freshen t)
|
|
||||||
(freshen* t
|
|
||||||
(lambda (var env) (variable (variable-info var)))
|
|
||||||
(lambda (var env) (variable (canonical-variable-index var)))))
|
|
||||||
|
|
||||||
;; Any -> Any
|
|
||||||
;;
|
|
||||||
;; Canonicalizes a term by substituting out variables in the term with
|
|
||||||
;; canonical-variables to produce a canonical member of the term's
|
|
||||||
;; alpha-equivalence-class.
|
|
||||||
;;
|
|
||||||
;; Canonical variables are used in a structurally-determined order
|
|
||||||
;; related to print order: generally, all unseen variables to the left
|
|
||||||
;; of a term's print representation are given canonical equivalents
|
|
||||||
;; before those to the right.
|
|
||||||
;;
|
|
||||||
;; Canonical-variables may not appear in the input term.
|
|
||||||
(define (canonicalize t)
|
|
||||||
(freshen* t
|
|
||||||
(lambda (var env) (canonical-variable (hash-count env)))
|
|
||||||
(lambda (var env) (canonical-variable (hash-count env)))))
|
|
||||||
|
|
||||||
;; Any Any -> Any
|
|
||||||
;; If the arguments unify, applies the substitution to one of them,
|
|
||||||
;; yielding a most general unifier, and then freshens the result.
|
|
||||||
(define (mgu-freshen a b)
|
|
||||||
(define sub (unify a b))
|
|
||||||
(and sub (freshen (apply-subst sub a))))
|
|
||||||
|
|
||||||
;; Any Any -> Any
|
|
||||||
;; If the arguments unify, applies the substitution to one of them,
|
|
||||||
;; yielding a most general unifier, and then canonicalizes the result.
|
|
||||||
(define (mgu-canonical a b)
|
|
||||||
(define sub (unify a b))
|
|
||||||
(and sub (canonicalize (apply-subst sub a))))
|
|
||||||
|
|
||||||
;; Subst Any -> Any
|
|
||||||
(define (apply-subst env x)
|
|
||||||
(let walk ((x0 x))
|
|
||||||
(define x (chase x0 env (set)))
|
|
||||||
(cond
|
|
||||||
[(pair? x) (cons (walk (car x)) (walk (cdr x)))]
|
|
||||||
[(vector? x) (list->vector (map walk (vector->list x)))]
|
|
||||||
[(non-object-struct? x) (struct-map walk x)]
|
|
||||||
[else x])))
|
|
||||||
|
|
||||||
;; True iff a is a specialization (or instance) of b.
|
|
||||||
(define (specialization? a b)
|
|
||||||
(let walk ((a a) (b b))
|
|
||||||
(cond
|
|
||||||
[(wild? b) #t]
|
|
||||||
[(wild? a) #f]
|
|
||||||
[(and (pair? a) (pair? b))
|
|
||||||
(and (walk (car a) (car b)) (walk (cdr a) (cdr b)))]
|
|
||||||
[(and (vector? a) (vector? b) (= (vector-length a) (vector-length b)))
|
|
||||||
(for/and ([aa a] [bb b]) (walk aa bb))]
|
|
||||||
[(and (non-object-struct? a) (non-object-struct? b))
|
|
||||||
(walk (struct->vector a #f) (struct->vector b #f))]
|
|
||||||
[else (equal? a b)])))
|
|
||||||
|
|
||||||
(require racket/trace)
|
|
||||||
(trace ;;unify/env
|
|
||||||
;;upper-case-symbols->variables
|
|
||||||
;;apply-subst
|
|
||||||
;;specialization?
|
|
||||||
)
|
|
104
vm.rkt
104
vm.rkt
|
@ -1,104 +0,0 @@
|
||||||
#lang racket/base
|
|
||||||
|
|
||||||
(require racket/match)
|
|
||||||
(require "structs.rkt")
|
|
||||||
(require "roles.rkt")
|
|
||||||
(require "quasiqueue.rkt")
|
|
||||||
|
|
||||||
(provide vm-processes ;; (struct-out vm) doesn't work because of make-vm below (See PR13161)
|
|
||||||
vm-next-process-id
|
|
||||||
vm
|
|
||||||
vm?
|
|
||||||
|
|
||||||
(struct-out process)
|
|
||||||
(struct-out endpoint)
|
|
||||||
(struct-out eid)
|
|
||||||
|
|
||||||
make-vm
|
|
||||||
inject-process
|
|
||||||
extract-process
|
|
||||||
always-false
|
|
||||||
reset-pending-actions
|
|
||||||
process-map
|
|
||||||
endpoint-fold)
|
|
||||||
|
|
||||||
(struct vm (processes ;; (HashTable PID Process)
|
|
||||||
next-process-id ;; PID
|
|
||||||
)
|
|
||||||
#:transparent)
|
|
||||||
|
|
||||||
(struct process (debug-name ;; Any
|
|
||||||
pid ;; PID
|
|
||||||
state ;; State
|
|
||||||
spawn-ks ;; (Listof (Pairof Integer (TrapK PID State))) ;; hmm
|
|
||||||
endpoints ;; (HashTable PreEID (endpoint State))
|
|
||||||
meta-endpoints ;; (HashTable PreEID (endpoint State))
|
|
||||||
pending-actions ;; (QuasiQueue (Action State))
|
|
||||||
)
|
|
||||||
#:transparent)
|
|
||||||
|
|
||||||
(struct endpoint (id ;; eid
|
|
||||||
role ;; role
|
|
||||||
handler ;; (Handler State)
|
|
||||||
)
|
|
||||||
#:transparent)
|
|
||||||
|
|
||||||
(struct eid (pid ;; PID
|
|
||||||
pre-eid ;; PreEID
|
|
||||||
)
|
|
||||||
#:transparent)
|
|
||||||
|
|
||||||
;;---------------------------------------------------------------------------
|
|
||||||
|
|
||||||
;; make-vm : process-spec -> vm
|
|
||||||
(define (make-vm boot)
|
|
||||||
(define primordial (process '#:primordial
|
|
||||||
-1
|
|
||||||
(void)
|
|
||||||
(list)
|
|
||||||
#hash()
|
|
||||||
#hash()
|
|
||||||
(quasiqueue (spawn boot #f '#:boot-process))))
|
|
||||||
(vm (hash-set #hash() (process-pid primordial) primordial) 0))
|
|
||||||
|
|
||||||
;; inject-process : vm Process -> vm
|
|
||||||
(define (inject-process state wp)
|
|
||||||
(struct-copy vm state [processes (hash-set (vm-processes state) (process-pid wp) wp)]))
|
|
||||||
|
|
||||||
;; always-false : -> False
|
|
||||||
(define (always-false) #f)
|
|
||||||
|
|
||||||
;; extract-process : vm PID -> (values vm (Option Process))
|
|
||||||
(define (extract-process state pid)
|
|
||||||
(define wp (hash-ref (vm-processes state) pid always-false))
|
|
||||||
(values (if wp
|
|
||||||
(struct-copy vm state [processes (hash-remove (vm-processes state) pid)])
|
|
||||||
state)
|
|
||||||
wp))
|
|
||||||
|
|
||||||
;; reset-pending-actions : (All (State) (process State) -> (process State))
|
|
||||||
(define (reset-pending-actions p)
|
|
||||||
(struct-copy process p [pending-actions (empty-quasiqueue)]))
|
|
||||||
|
|
||||||
;; process-map : (All (State) (process State) -> (process State)) vm -> vm
|
|
||||||
;; TODO: simplify
|
|
||||||
(define (process-map f state)
|
|
||||||
(for/fold ([state state]) ([pid (in-hash-keys (vm-processes state))])
|
|
||||||
(let-values (((state wp) (extract-process state pid)))
|
|
||||||
(if (not wp)
|
|
||||||
state
|
|
||||||
(inject-process state (f wp))))))
|
|
||||||
|
|
||||||
;; endpoint-fold : (All (A) (All (State) (process State) (endpoint State) A -> A) A vm -> A)
|
|
||||||
(define (endpoint-fold f seed state)
|
|
||||||
(for/fold ([seed seed]) ([pid (in-hash-keys (vm-processes state))])
|
|
||||||
(let-values (((state wp) (extract-process state pid)))
|
|
||||||
(if (not wp)
|
|
||||||
seed
|
|
||||||
(for/fold ([seed seed]) ([pre-eid (in-hash-keys (process-endpoints wp))])
|
|
||||||
(define ep (hash-ref (process-endpoints wp) pre-eid))
|
|
||||||
(f wp ep seed))))))
|
|
||||||
|
|
||||||
;;; Local Variables:
|
|
||||||
;;; eval: (put 'unwrap-process 'scheme-indent-function 3)
|
|
||||||
;;; End:
|
|
Loading…
Reference in New Issue