Update examples

This commit is contained in:
Tony Garnock-Jones 2017-02-20 12:54:52 -05:00
parent 1134ed0eff
commit 1f8bb56c69
35 changed files with 147 additions and 147 deletions

View File

@ -29,8 +29,8 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (spawn-arp-driver)
(actor #:name 'arp-driver
(during/actor (arp-interface $interface-name)
(spawn #:name 'arp-driver
(during/spawn (arp-interface $interface-name)
#:name (list 'arp-interface interface-name)
(assert (arp-interface-up interface-name))
(on-start (define hwaddr (lookup-ethernet-hwaddr interface-name))

View File

@ -5,16 +5,16 @@
(require (only-in mzlib/os gethostname))
(require "configuration.rkt")
(actor
(spawn
(match (gethostname)
["skip"
(assert (gateway-route (bytes 0 0 0 0) 0 (bytes 192 168 1 1) "en0"))
(assert (host-route (bytes 192 168 1 222) 24 "en0"))]
[(or "hop" "walk")
(assert (gateway-route (bytes 0 0 0 0) 0 (bytes 192 168 1 1) "wlan0"))
(assert (host-route (bytes 192 168 1 222) 24 "wlan0"))]
["stockholm.ccs.neu.edu"
(assert (host-route (bytes 129 10 115 94) 24 "eth0"))
(assert (gateway-route (bytes 0 0 0 0) 0 (bytes 129 10 115 1) "eth0"))]
[other
(error 'demo-config "No setup for hostname ~a" other)]))
[other ;; assume a private network
(define interface
(match other
["skip" "en0"]
["leap" "wlp4s0"] ;; wtf
[_ "wlan0"]))
(assert (gateway-route (bytes 0 0 0 0) 0 (bytes 192 168 1 1) interface))
(assert (host-route (bytes 192 168 1 222) 24 interface))]))

View File

@ -29,8 +29,8 @@
(log-info "Device names: ~a" interface-names)
(define (spawn-ethernet-driver)
(actor #:name 'ethernet-driver
(during/actor
(spawn #:name 'ethernet-driver
(during/spawn
(observe (ethernet-packet (ethernet-interface $interface-name _) #t _ _ _ _))
#:name (list 'ethernet-interface interface-name)
@ -46,7 +46,7 @@
(on-start (flush!) ;; ensure all subscriptions are in place
(async-channel-put control-ch 'unblock)
(actor #:name (list 'ethernet-interface-quit-monitor interface-name)
(spawn #:name (list 'ethernet-interface-quit-monitor interface-name)
(on (retracted interface)
(async-channel-put control-ch 'quit))))

View File

@ -57,15 +57,15 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (spawn-ip-driver)
(actor #:name 'ip-driver
(during/actor (host-route $my-address $netmask $interface-name)
(spawn #:name 'ip-driver
(during/spawn (host-route $my-address $netmask $interface-name)
(assert (route-up (host-route my-address netmask interface-name)))
(do-host-route my-address netmask interface-name))
(during/actor (gateway-route $network $netmask $gateway-addr $interface-name)
(during/spawn (gateway-route $network $netmask $gateway-addr $interface-name)
(assert (route-up
(gateway-route $network $netmask $gateway-addr $interface-name)))
(do-gateway-route network netmask gateway-addr interface-name))
(during/actor (net-route $network-addr $netmask $link)
(during/spawn (net-route $network-addr $netmask $link)
(assert (route-up (net-route network-addr netmask link)))
(do-net-route network-addr netmask link))))

View File

@ -19,7 +19,7 @@
(struct present (who) #:prefab)
(define (spawn-session them us)
(actor (define (send-to-remote fmt . vs)
(spawn (define (send-to-remote fmt . vs)
(send! (outbound (tcp-channel us them (string->bytes/utf-8 (apply format fmt vs))))))
(define (say who fmt . vs)
@ -48,14 +48,14 @@
(spawn-session them us)))))
(let ((dst (udp-listener 6667)))
(actor #:name 'udp-echo-program
(spawn #:name 'udp-echo-program
(on (message (udp-packet $src dst $body))
(log-info "Got packet from ~v: ~v" src body)
(send! (udp-packet dst src (string->bytes/utf-8 (format "You said: ~a" body)))))))
(let ()
(dataspace #:name 'webserver-dataspace
(actor #:name 'webserver-counter
(spawn #:name 'webserver-counter
(field [counter 0])
(on (message 'bump)
(send! `(counter ,(counter)))
@ -63,7 +63,7 @@
(forever (define us (tcp-listener 80))
(assert (outbound (advertise (observe (tcp-channel _ us _)))))
(during/actor (inbound (advertise (tcp-channel ($ them (tcp-address _ _)) us _)))
(during/spawn (inbound (advertise (tcp-channel ($ them (tcp-address _ _)) us _)))
#:name (list 'webserver-session them)
(log-info "Got connection from ~v" them)
(field [done? #f])

View File

@ -13,7 +13,7 @@
(struct port-allocation-reply (reqid port) #:prefab)
(define (spawn-port-allocator allocator-type query-used-ports)
(actor #:name (list 'port-allocator allocator-type)
(spawn #:name (list 'port-allocator allocator-type)
(define local-ips (query-local-ip-addresses))
(define used-ports (query-used-ports))

View File

@ -52,8 +52,8 @@
(define (spawn-tcp-driver)
(spawn-port-allocator 'tcp (lambda () (query-set tcp-ports (tcp-port-allocation $p _) p)))
(spawn-kernel-tcp-driver)
(actor #:name 'tcp-inbound-driver
(during/actor (advertise (observe (tcp-channel _ ($ server-addr (tcp-listener _)) _)))
(spawn #:name 'tcp-inbound-driver
(during/spawn (advertise (observe (tcp-channel _ ($ server-addr (tcp-listener _)) _)))
#:name (list 'tcp-listen server-addr)
(match-define (tcp-listener port) server-addr)
(assert (tcp-port-allocation port server-addr))
@ -61,7 +61,7 @@
($ local-addr (tcp-address _ port))
_)))
(spawn-relay server-addr remote-addr local-addr))))
(actor #:name 'tcp-outbound-driver
(spawn #:name 'tcp-outbound-driver
(define local-ips (query-local-ip-addresses))
(on (asserted (advertise (tcp-channel ($ local-addr (tcp-handle _))
($ remote-addr (tcp-address _ _))
@ -92,7 +92,7 @@
(define (spawn-relay local-user-addr remote-addr local-tcp-addr)
(define timer-name (list 'spawn-relay local-tcp-addr remote-addr))
(actor #:name (list 'tcp-relay local-user-addr remote-addr local-tcp-addr)
(spawn #:name (list 'tcp-relay local-user-addr remote-addr local-tcp-addr)
(assert (tcp-port-allocation (tcp-address-port local-tcp-addr) local-user-addr))
(assert (advertise (tcp-channel remote-addr local-user-addr _)))
(assert (advertise (tcp-channel local-tcp-addr remote-addr _)))
@ -125,7 +125,7 @@
(define PROTOCOL-TCP 6)
(define (spawn-kernel-tcp-driver)
(actor #:name 'kernel-tcp-driver
(spawn #:name 'kernel-tcp-driver
(define local-ips (query-local-ip-addresses))
(define active-state-vectors
@ -297,7 +297,7 @@
(define dst (tcp-address (ip-address->hostname dst-ip) dst-port))
(define (timer-name kind) (list 'tcp-timer kind src dst))
(actor
(spawn
#:name (list 'tcp-state-vector
(ip-address->hostname src-ip)
src-port

View File

@ -50,18 +50,18 @@
(define (spawn-udp-driver)
(spawn-port-allocator 'udp (lambda () (query-set udp-ports (udp-port-allocation $p _) p)))
(spawn-kernel-udp-driver)
(actor #:name 'udp-driver
(spawn #:name 'udp-driver
(on (asserted (observe (udp-packet _ ($ h (udp-listener _)) _)))
(spawn-udp-relay (udp-listener-port h) h))
(on (asserted (observe (udp-packet _ ($ h (udp-handle _)) _)))
(actor #:name (list 'udp-transient h)
(spawn #:name (list 'udp-transient h)
(on-start (spawn-udp-relay (allocate-port! 'udp) h))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Relaying
(define (spawn-udp-relay local-port local-user-addr)
(actor #:name (list 'udp-relay local-port local-user-addr)
(spawn #:name (list 'udp-relay local-port local-user-addr)
(on-start (log-info "Spawning UDP relay ~v / ~v" local-port local-user-addr))
(define any-remote (udp-remote-address ? ?))
@ -97,7 +97,7 @@
(define PROTOCOL-UDP 17)
(define (spawn-kernel-udp-driver)
(actor #:name 'kernel-udp-driver
(spawn #:name 'kernel-udp-driver
(assert (advertise (ip-packet #f _ _ PROTOCOL-UDP _ _)))
(define local-ips (query-local-ip-addresses))

View File

@ -215,7 +215,7 @@
(cache-key-address q)))))))
(list (set-wakeup-alarm)
(spawn (lambda (e s)
(actor (lambda (e s)
;; (log-info "ARP ~a ~a: ~v // ~v" interface-name (pretty-bytes hwaddr) e s)
(match e
[(scn g)

View File

@ -9,17 +9,17 @@
(provide spawn-demo-config)
(define (spawn-demo-config)
(spawn (lambda (e s) #f)
(actor (lambda (e s) #f)
(void)
(match (gethostname)
["skip"
(scn/union (assertion (gateway-route (bytes 0 0 0 0) 0 (bytes 192 168 1 1) "en0"))
(assertion (host-route (bytes 192 168 1 222) 24 "en0")))]
[(or "hop" "walk")
(scn/union (assertion (gateway-route (bytes 0 0 0 0) 0 (bytes 192 168 1 1) "wlan0"))
(assertion (host-route (bytes 192 168 1 222) 24 "wlan0")))]
["stockholm.ccs.neu.edu"
(scn/union (assertion (host-route (bytes 129 10 115 94) 24 "eth0"))
(assertion (gateway-route (bytes 0 0 0 0) 0 (bytes 129 10 115 1) "eth0")))]
[else
(error 'spawn-demo-config "No setup for hostname ~a" (gethostname))])))
[other ;; assume a private network
(define interface
(match other
["skip" "en0"]
["leap" "wlp4s0"] ;; wtf
[_ "wlan0"]))
(scn/union (assertion (gateway-route (bytes 0 0 0 0) 0 (bytes 192 168 1 1) interface))
(assertion (host-route (bytes 192 168 1 222) 24 interface)))])))

View File

@ -47,7 +47,7 @@
(log-info "Opened interface ~a, yielding handle ~v" interface-name h)
(define control-ch (make-async-channel))
(thread (lambda () (interface-packet-read-loop interface h control-ch)))
(spawn (lambda (e h)
(actor (lambda (e h)
(match e
[(scn g)
(if (trie-empty? g)

View File

@ -83,7 +83,7 @@
network-addr
netmask
interface-name))
(spawn (lambda (e s)
(actor (lambda (e s)
(match e
[(scn (? trie-empty?)) (quit)]
[(message (ip-packet _ peer-address _ _ _ body))
@ -143,7 +143,7 @@
(and (positive? msk)
(ip-address-in-subnet? addr net msk))))
(spawn (lambda (e s)
(actor (lambda (e s)
(match e
[(scn g)
(define host-ips+netmasks (trie-project/set #:take 2 g host-route-projector))
@ -202,7 +202,7 @@
;; Normal IP route
(define (spawn-normal-ip-route the-route network netmask interface-name)
(spawn (lambda (e s)
(actor (lambda (e s)
(match e
[(scn (? trie-empty?)) (quit)]
[(message (ethernet-packet _ _ _ _ _ body))

View File

@ -34,7 +34,7 @@
(define (say who fmt . vs)
(unless (equal? who user) (send-to-remote "~a ~a\n" who (apply format fmt vs))))
(list (send-to-remote "Welcome, ~a.\n" user)
(spawn
(actor
(lambda (e peers)
(match e
[(message (inbound (tcp-channel _ _ bs)))
@ -68,7 +68,7 @@
)
(let ()
(spawn (lambda (e s)
(actor (lambda (e s)
(match e
[(message (udp-packet src dst body))
(log-info "Got packet from ~v: ~v" src body)
@ -84,7 +84,7 @@
(define (spawn-session them us)
(list
(message 'bump)
(spawn (lambda (e s)
(actor (lambda (e s)
(match e
[(message `(counter ,counter))
(define response
@ -106,7 +106,7 @@
(advertisement (inbound (tcp-channel us them ?)))))))
(spawn-dataspace
(spawn (lambda (e counter)
(actor (lambda (e counter)
(match e
[(message 'bump)
(transition (+ counter 1) (message `(counter ,counter)))]

View File

@ -10,14 +10,14 @@
;; -> Action
;; Spawns a process that observes the given projections. Any time the
;; environment's interests change in a relevant way, calls
;; check-and-maybe-spawn-fn with the aggregate interests and the
;; projection results. If check-and-maybe-spawn-fn returns #f,
;; check-and-maybe-actor-fn with the aggregate interests and the
;; projection results. If check-and-maybe-actor-fn returns #f,
;; continues to wait; otherwise, takes the action(s) returned, and
;; quits.
(define (on-claim #:timeout-msec [timeout-msec #f]
#:on-timeout [timeout-handler (lambda () '())]
#:name [name #f]
check-and-maybe-spawn-fn
check-and-maybe-actor-fn
base-interests
. projections)
(define timer-id (gensym 'on-claim))
@ -27,18 +27,18 @@
(define projection-results
(map (lambda (p) (trie-project/set #:take (projection-arity p) new-aggregate p))
projections))
(define maybe-spawn (apply check-and-maybe-spawn-fn
(define maybe-actor (apply check-and-maybe-actor-fn
new-aggregate
projection-results))
(if maybe-spawn
(quit maybe-spawn)
(if maybe-actor
(quit maybe-actor)
#f)]
[(message (timer-expired (== timer-id) _))
(quit (timeout-handler))]
[_ #f]))
(list
(when timeout-msec (message (set-timer timer-id timeout-msec 'relative)))
(spawn #:name name
(actor #:name name
on-claim-handler
(void)
(scn/union base-interests

View File

@ -14,7 +14,7 @@
(struct port-allocator-state (used-ports local-ips) #:transparent)
(define (spawn-port-allocator allocator-type observer-gestalt compute-used-ports)
(spawn #:name (string->symbol (format "port-allocator:~a" allocator-type))
(actor #:name (string->symbol (format "port-allocator:~a" allocator-type))
(lambda (e s)
(match e
[(scn g)

View File

@ -59,7 +59,7 @@
(match-define (tcp-listener port) server-addr)
;; TODO: have listener shut down once user-level listener does
(list
(spawn #:name (string->symbol
(actor #:name (string->symbol
(format "tcp-listener-port-reservation:~a" port))
(lambda (e s) #f)
(void)
@ -122,7 +122,7 @@
(define remote-peer-traffic (?! (advertise (tcp-channel remote-addr local-tcp-addr ?))))
(list
(message (set-timer timer-name relay-peer-wait-time-msec 'relative))
(spawn #:name (string->symbol (format "tcp-relay:~v:~v:~v"
(actor #:name (string->symbol (format "tcp-relay:~v:~v:~v"
local-user-addr
remote-addr
local-tcp-addr))
@ -294,7 +294,7 @@
(transition s (message (ip-packet #f src-ip dst-ip PROTOCOL-TCP #""
(ip-checksum 16 payload #:pseudo-header pseudo-header)))))
(spawn #:name 'kernel-tcp-driver
(actor #:name 'kernel-tcp-driver
(lambda (e s)
(match e
[(scn g)
@ -655,7 +655,7 @@
(current-inexact-milliseconds)
#f
#f)))
(spawn #:name
(actor #:name
(string->symbol (format "tcp-state-vector:~a:~a:~a:~a"
(ip-address->hostname src-ip)
src-port

View File

@ -92,7 +92,7 @@
(subscription (udp-datagram ? ? ip local-port ?))
(advertisement (udp-datagram ip local-port ? ? ?)))))
(spawn (lambda (e local-ips)
(actor (lambda (e local-ips)
(match e
[(scn g)
(define new-local-ips (gestalt->local-ip-addresses g))
@ -124,7 +124,7 @@
(define PROTOCOL-UDP 17)
(define (spawn-kernel-udp-driver)
(spawn (lambda (e local-ips)
(actor (lambda (e local-ips)
(match e
[(scn g)
(transition (gestalt->local-ip-addresses g) '())]

View File

@ -18,11 +18,11 @@
(define cmdline-port (make-parameter 5889))
(define cmdline-filenames (make-parameter '()))
(actor* (for [(filename (cmdline-filenames))]
(spawn* (for [(filename (cmdline-filenames))]
(run-one-server filename)))
(define (run-one-server filename)
(actor (field [state (make-server (simple-document
(spawn (field [state (make-server (simple-document
(if (file-exists? filename)
(begin (log-info "loading ~v" filename)
(file->string filename))
@ -51,10 +51,10 @@
(define sp (extract-operation (state)))
(when sp (send! (accepted-op filename sp))))))
(actor (define s (tcp-listener (cmdline-port)))
(spawn (define s (tcp-listener (cmdline-port)))
(on-start (log-info "listening on port ~v" (cmdline-port)))
(assert (advertise (observe (tcp-channel _ s _))))
(during/actor (advertise (tcp-channel $c s _))
(during/spawn (advertise (tcp-channel $c s _))
(assert (advertise (tcp-channel s c _)))
(on-start (log-info "~a: connected" c))
(on-stop (log-info "~a: disconnected" c))

View File

@ -16,7 +16,7 @@
(define cmdline-port (make-parameter 5888))
(define cmdline-filename (make-parameter "info.rkt"))
(actor (field [state (make-server (simple-document
(spawn (field [state (make-server (simple-document
(if (file-exists? (cmdline-filename))
(begin (log-info "loading ~v" (cmdline-filename))
(file->string (cmdline-filename)))
@ -45,10 +45,10 @@
(define sp (extract-operation (state)))
(when sp (send! (accepted-op sp)))))
(actor (define s (tcp-listener (cmdline-port)))
(spawn (define s (tcp-listener (cmdline-port)))
(on-start (log-info "listening on port ~v" (cmdline-port)))
(assert (advertise (observe (tcp-channel _ s _))))
(during/actor (advertise (tcp-channel $c s _))
(during/spawn (advertise (tcp-channel $c s _))
(assert (advertise (tcp-channel s c _)))
(on-start (log-info "~a: connected" c))
(on-stop (log-info "~a: disconnected" c))

View File

@ -302,7 +302,7 @@
;; SceneManager
(define (spawn-scene-manager)
(actor #:name 'scene-manager
(spawn #:name 'scene-manager
(define backdrop (rectangle 1 1 "solid" "white"))
(define/query-value size (vector 0 0) (inbound (window $x $y)) (vector x y))
@ -337,7 +337,7 @@
;; ScoreKeeper
(define (spawn-score-keeper)
(actor #:name 'score-keeper
(spawn #:name 'score-keeper
(field [score 0])
(assert (current-score (score)))
(assert (outbound
@ -356,7 +356,7 @@
(define gravity 0.004)
(define (spawn-physics-engine)
(actor #:name 'physics-engine
(spawn #:name 'physics-engine
(field [configs (hash)]
[previous-positions (hash)]
[previous-velocities (hash)]
@ -535,7 +535,7 @@
(define planetcute-scale 1/2)
(define (spawn-player-avatar initial-focus-x initial-focus-y)
(actor #:name 'player-avatar
(spawn #:name 'player-avatar
(define i (icon character-cat-girl planetcute-scale 2/6 3/10 13/16))
(define initial-top-left (focus->top-left i initial-focus-x initial-focus-y))
@ -567,7 +567,7 @@
;; Ground Block
(define (spawn-ground-block top-left size #:color [color "purple"])
(actor #:name (list 'ground-block top-left size color)
(spawn #:name (list 'ground-block top-left size color)
(match-define (vector x y) top-left)
(match-define (vector w h) size)
(define block-id (gensym 'ground-block))
@ -589,7 +589,7 @@
(define i (icon key planetcute-scale 1/3 2/5 4/5))
(define initial-top-left (focus->top-left i initial-focus-x initial-focus-y))
(actor #:name (list 'goal-piece initial-focus-x initial-focus-y)
(spawn #:name (list 'goal-piece initial-focus-x initial-focus-y)
(on (asserted (touching player-id goal-id _))
(send! (outbound (level-completed))))
(assert (game-piece-configuration goal-id
@ -604,7 +604,7 @@
(define (spawn-enemy initial-x initial-y range-lo range-hi
#:speed [speed 0.2]
#:facing [initial-facing 'right])
(actor #:name (list 'enemy initial-x initial-y initial-facing)
(spawn #:name (list 'enemy initial-x initial-y initial-facing)
(define enemy-id (gensym 'enemy))
(define i (icon enemy-bug planetcute-scale 9/10 1/3 5/6))
(define i-flipped (struct-copy icon i [pict (flip-horizontal (icon-pict i))]))
@ -647,7 +647,7 @@
(define (spawn-display-controller level-size-vec)
(match-define (vector level-width level-height) level-size-vec)
(actor #:name 'display-controller
(spawn #:name 'display-controller
(field [offset-pos (vector 0 0)])
(assert (outbound* 2 (scroll-offset (offset-pos))))
(assert (level-size level-size-vec))
@ -687,7 +687,7 @@
;; LevelSpawner
(define (spawn-standalone-assertions . patches)
(actor #:name 'standalone-assertions
(spawn #:name 'standalone-assertions
(on-start (patch! (patch-seq* patches)))))
(define (spawn-background-image level-size scene)
@ -778,7 +778,7 @@
message))))))
(define (spawn-level-spawner starting-level)
(actor #:name 'level-spawner
(spawn #:name 'level-spawner
(field [current-level starting-level]
[level-complete? #f])

View File

@ -335,7 +335,7 @@
p
(?! (on-screen-display ? ? ?)))]))
(spawn (lambda (e s)
(actor (lambda (e s)
(match e
[(? patch? p)
(let* ((s (update-window-size s p))
@ -381,7 +381,7 @@
(define i (text (format "Score: ~a" new-score) 24 "white"))
(patch-seq (retract (outbound (on-screen-display ? ? ?)))
(assert (outbound (on-screen-display -150 10 (seal i))))))
(spawn (lambda (e s)
(actor (lambda (e s)
(match e
[(message (add-to-score delta))
(define new-score (+ s delta))
@ -603,7 +603,7 @@
(play-sound-sequence 270318)
((update-piece g pos (v+ pos (vector 0 -1)) jump-vel) s)))
(spawn (lambda (e s)
(actor (lambda (e s)
(match e
[(? patch? p)
(sequence-transitions (transition s '())
@ -679,7 +679,7 @@
(patch-seq (retract (impulse player-id ?))
(assert (impulse player-id (vector h-impulse 0)))))))
(spawn (lambda (e s)
(actor (lambda (e s)
(match e
[(? patch? p)
(sequence-transitions (transition s '())
@ -720,7 +720,7 @@
(match-define (vector w h) size)
(define block-id (gensym 'ground-block))
(define block-pict (rectangle w h "solid" color))
(spawn (lambda (e s)
(actor (lambda (e s)
(match e
[_ #f]))
(void)
@ -742,7 +742,7 @@
(define i (icon key planetcute-scale 1/3 2/5 4/5))
(define initial-top-left (focus->top-left i initial-focus-x initial-focus-y))
(spawn (lambda (e s)
(actor (lambda (e s)
(match e
[(? patch/added?) (transition s (message (outbound (level-completed))))]
[_ #f]))
@ -824,7 +824,7 @@
(quit (list damage-actions (message (outbound (add-to-score 1))))))
(transition s damage-actions)))
(spawn (lambda (e s)
(actor (lambda (e s)
(match e
[(? patch? p)
(sequence-transitions (transition s '())
@ -874,7 +874,7 @@
(patch-seq (retract (outbound* 2 (scroll-offset ?)))
(assert (outbound* 2 (scroll-offset offset-pos))))))))))
(spawn (lambda (e s)
(actor (lambda (e s)
(match e
[(? patch? p)
(sequence-transitions (transition s '())
@ -893,7 +893,7 @@
;; kills the dataspace.
(define (spawn-level-termination-monitor)
(spawn (lambda (e s)
(actor (lambda (e s)
(match e
[(? patch/removed?)
(log-info "Player died! Terminating level.")
@ -914,7 +914,7 @@
;; LevelSpawner
(define (spawn-standalone-assertions . patches)
(spawn (lambda (e s) #f)
(actor (lambda (e s) #f)
(void)
patches))
@ -1005,7 +1005,7 @@
(define (spawn-level-spawner starting-level)
(struct level-spawner-state (current-level level-complete?) #:prefab)
(list (spawn (lambda (e s)
(list (actor (lambda (e s)
(match-define (level-spawner-state current-level level-complete?) s)
(match e
[(? patch/removed?)

View File

@ -106,7 +106,7 @@
Syndicate.Broker.spawnBrokerClientDriver();
spawnInputChangeMonitor();
actor {
spawn {
this.ui = new Syndicate.UI.Anchor();
var mainpage_c = this.ui.context('mainpage');
@ -472,7 +472,7 @@
var spawnItemFromDataURL = (function (ui) {
return function (dataURL) {
var timestamp = +(new Date());
actor {
spawn {
field this.ui = ui.context('draft-post', timestamp);
assert draftItem(timestamp, dataURL);
manifestPostItem(this.ui,
@ -804,8 +804,8 @@ function spawnInputChangeMonitor() {
return e ? (e.type === 'checkbox' ? e.checked : e.value) : null;
}
actor {
during Syndicate.observe(inputValue($selector, _)) actor {
spawn {
during Syndicate.observe(inputValue($selector, _)) spawn {
field this.value = valOf($(selector)[0]);
assert inputValue(selector, this.value);
on message Syndicate.UI.globalEvent(selector, 'change', $e) {

View File

@ -8,17 +8,17 @@
(require "protocol.rkt")
(require "duplicate.rkt")
(actor #:name 'account-manager
(spawn #:name 'account-manager
(stop-when-reloaded)
(define/query-set accounts (account $e) e)
(on (asserted (session $email _))
(when (not (set-member? (accounts) email))
(send! (create-resource (account email))))))
(actor #:name 'account-factory
(spawn #:name 'account-factory
(stop-when-reloaded)
(on (message (create-resource ($ a (account $email))))
(actor #:name (list 'account email)
(spawn #:name (list 'account email)
(on-start (log-info "Account ~s created." email))
(on-stop (log-info "Account ~s deleted." email))
(assert a)

View File

@ -9,7 +9,7 @@
(require "protocol.rkt")
(require "session-cookie.rkt")
(actor #:name 'broker-listener
(spawn #:name 'broker-listener
(stop-when-reloaded)
(on (web-request-get (id req) _ ("broker" ()))
(when (web-request-header-websocket-upgrade? req)
@ -31,7 +31,7 @@
(a ((href "/")) "Login"))))]))))
(supervise
(actor #:name 'reflect-trust
(spawn #:name 'reflect-trust
(stop-when-reloaded)
(during (session $who _)
(during ($ p (permitted _ who _ _))
@ -44,7 +44,7 @@
(assert (api (session who _) c))))))
(supervise
(actor #:name 'reflect-grant-requests
(spawn #:name 'reflect-grant-requests
(stop-when-reloaded)
(during (permission-request $issuer $grantee $permission)
(define r (permission-request issuer grantee permission))
@ -54,7 +54,7 @@
(send! (delete-resource r)))))))
(supervise
(actor #:name 'take-trust-instructions
(spawn #:name 'take-trust-instructions
(stop-when-reloaded)
(on (message (api (session $grantor _) (create-resource (? grant? $g))))

View File

@ -15,17 +15,17 @@
#:once-each
["--baseurl" baseurl "Specify the base URL for the server"
(actor #:name (list 'command-line-baseurl baseurl)
(spawn #:name (list 'command-line-baseurl baseurl)
(stop-when-reloaded)
(assert (config 'command-line (list 'baseurl baseurl))))]
["--listen" port "Specify HTTP listener port"
(actor #:name (list 'command-line-listen port)
(spawn #:name (list 'command-line-listen port)
(stop-when-reloaded)
(assert (config 'command-line (list 'listen (string->number port)))))]
#:multi
[("-o" "--option") key vals "Specify a single configuration option"
(actor #:name (list 'config-option key vals)
(spawn #:name (list 'config-option key vals)
(stop-when-reloaded)
(assert (config 'command-line
(cons (string->symbol key)
@ -34,14 +34,14 @@
(spawn-configuration filename filename
#:hook (lambda () (stop-when-reloaded)))])
(actor #:name 'main
(spawn #:name 'main
(stop-when-reloaded)
(during (config _ (list 'baseurl $u)) (assert (server-baseurl u)))
(during (config _ (list 'listen $p)) (assert (web-virtual-host "http" _ p)))
(during/actor (config _ (list 'load $module-path))
#:actor supervise/actor
(during/spawn (config _ (list 'load $module-path))
#:spawn supervise/spawn
#:name (list 'load module-path)
(reloader-mixin* module-path))

View File

@ -13,7 +13,7 @@
(struct present (email) #:prefab)
(supervise
(actor #:name 'reflect-presence
(spawn #:name 'reflect-presence
(stop-when-reloaded)
(during (api (session $who _) (online))
(during (permitted who $grantee (p:follow who) _)
@ -21,7 +21,7 @@
(assert (api (session grantee _) (present who)))))))
(supervise
(actor #:name 'ensure-p:follow-symmetric
(spawn #:name 'ensure-p:follow-symmetric
(stop-when-reloaded)
(on (asserted (permitted $A $B (p:follow $maybe-A) _))
(when (equal? A maybe-A)
@ -36,7 +36,7 @@
(send! (delete-resource (permitted B A (p:follow B) ?))))))))
(supervise
(actor #:name 'contact-list-factory
(spawn #:name 'contact-list-factory
(stop-when-reloaded)
(during (permission-request $A $B (p:follow $maybe-A))
(when (equal? A maybe-A)
@ -49,7 +49,7 @@
(assert (contact-list-entry B A))))))))
(supervise
(actor #:name 'contact-list-change-log
(spawn #:name 'contact-list-change-log
(stop-when-reloaded)
(on (asserted (contact-list-entry $owner $member))
(log-info "~s adds ~s to their contact list" owner member))
@ -57,7 +57,7 @@
(log-info "~s removes ~s from their contact list" owner member))))
(supervise
(actor #:name 'contacts:questions
(spawn #:name 'contacts:questions
(stop-when-reloaded)
;; TODO: CHECK THE FOLLOWING: When the `permission-request` vanishes (due to
;; satisfaction or rejection), this should remove the question from all eligible

View File

@ -15,7 +15,7 @@
(immediate-query [query-value #f (in-conversation cid who) #t]))
(supervise
(actor #:name 'take-conversation-instructions
(spawn #:name 'take-conversation-instructions
(stop-when-reloaded)
(on (message (api (session $creator _) (create-resource (? conversation? $c))))
@ -55,7 +55,7 @@
(send! (delete-resource p))))))
(supervise
(actor #:name 'relay-conversation-state
(spawn #:name 'relay-conversation-state
(stop-when-reloaded)
(during (invitation $cid $inviter $invitee)
@ -74,10 +74,10 @@
(assert (api (session who _) p))))))
(supervise
(actor #:name 'conversation-factory
(spawn #:name 'conversation-factory
(stop-when-reloaded)
(on (message (create-resource ($ c0 (conversation $cid $title0 $creator $blurb0))))
(actor #:name c0
(spawn #:name c0
(field [title title0]
[blurb blurb0])
(define/dataflow c (conversation cid (title) creator (blurb)))
@ -91,10 +91,10 @@
(blurb newblurb))))))
(supervise
(actor #:name 'in-conversation-factory
(spawn #:name 'in-conversation-factory
(stop-when-reloaded)
(on (message (create-resource ($ i (in-conversation $cid $who))))
(actor #:name i
(spawn #:name i
(on-start (log-info "~s joins conversation ~a" who cid))
(on-stop (log-info "~s leaves conversation ~a" who cid))
(assert i)
@ -103,10 +103,10 @@
(stop-when (message (delete-resource (conversation cid _ _ _))))))))
(supervise
(actor #:name 'invitation-factory
(spawn #:name 'invitation-factory
(stop-when-reloaded)
(on (message (create-resource ($ i (invitation $cid $inviter $invitee))))
(actor #:name i
(spawn #:name i
(on-start (log-info "~s invited to conversation ~a by ~s" invitee cid inviter))
(on-stop (log-info "invitation of ~s to conversation ~a by ~s retracted"
invitee cid inviter))
@ -117,11 +117,11 @@
(stop-when (asserted (in-conversation cid invitee)))))))
(supervise
(actor #:name 'post-factory
(spawn #:name 'post-factory
(stop-when-reloaded)
(on (message (create-resource
($ p0 (post $pid $timestamp $cid $author $items0))))
(actor #:name p0
(spawn #:name p0
(field [items items0])
(define/dataflow p (post pid timestamp cid author (items)))
(assert (p))
@ -132,7 +132,7 @@
(items newitems))))))
(supervise
(actor #:name 'conversation:questions
(spawn #:name 'conversation:questions
(stop-when-reloaded)
;; TODO: CHECK THE FOLLOWING: When the `invitation` vanishes (due to satisfaction
;; or rejection), this should remove the question from all eligible answerers at once

View File

@ -114,7 +114,7 @@
;; for xexprs from Greg's Markdown package.
(display-xexpr body-xexpr))))))
(actor #:name 'index-page
(spawn #:name 'index-page
(stop-when-reloaded)
(on (web-request-get (id req) _ ("" ()))
(index-page id)))
@ -179,7 +179,7 @@
;; (logout-this-session! id)]
;; [else (logout-this-session! id)]))
(actor #:name 'logout-page
(spawn #:name 'logout-page
(stop-when-reloaded)
(on (web-request-get (id req) _ ("logout" ()))
(logout-page id)))
@ -191,7 +191,7 @@
(logout-this-session! id)]
[else (logout-this-session! id)]))
(actor #:name 'login-page
(spawn #:name 'login-page
(stop-when-reloaded)
(define/query-value insecure #f (config _ (list 'insecure)) #t)
(define/query-value baseurl #f (server-baseurl $b) b)
@ -219,7 +219,7 @@
(format " ~a" validation-url))))))))
(define (spawn-login-link email sid)
(actor #:name (list 'login-link email sid)
(spawn #:name (list 'login-link email sid)
(on-start (log-info "Login link ~s for ~s activated." sid email))
(on-stop (log-info "Login link ~s for ~s deactivated." sid email))
(assert (login-link email sid))
@ -242,7 +242,7 @@
"A login link should appear "
"in your inbox shortly."))))))
(actor #:name 'login-link-page
(spawn #:name 'login-link-page
(stop-when-reloaded)
;; Can't handle the request within each login-link process, since we have to take
;; special action if there is no such login link, and we are not allowed to race,
@ -264,10 +264,10 @@
"Please " (a ((href "/")) "return to the main page") ".")))))
(supervise
(actor #:name 'session-monitor-factory
(spawn #:name 'session-monitor-factory
(stop-when-reloaded)
(on (message (create-resource ($ s (session $email $sid))))
(actor #:name (list 'session-monitor email sid)
(spawn #:name (list 'session-monitor email sid)
(on-start (log-info "Session ~s for ~s started." sid email))
(on-stop (log-info "Session ~s for ~s stopped." sid email))
(assert s)

View File

@ -12,7 +12,7 @@
(require "util.rkt")
(supervise
(actor #:name 'qa-relay
(spawn #:name 'qa-relay
(stop-when-reloaded)
(during ($ q (question _ _ _ _ _ _ _))
(define qid (question-id q))

View File

@ -8,11 +8,11 @@
(require/activate syndicate/drivers/filesystem)
(require/activate syndicate/drivers/web)
(actor #:name 'script-compiler
(spawn #:name 'script-compiler
(stop-when-reloaded)
(define source-filename "../htdocs/webchat.syndicate.js")
(define target-filename "webchat.js")
(during/actor (file-content source-filename file->bytes $bs)
(during/spawn (file-content source-filename file->bytes $bs)
#:name (list 'compiled source-filename)
(define compiled (with-output-to-bytes
(lambda () (system* "../../../js/bin/syndicatec" source-filename))))

View File

@ -17,7 +17,7 @@
(define-runtime-path templates-path "../htdocs/templates")
(define path->mime-type (make-path->mime-type "/etc/mime.types")))
(actor #:name 'static-content-server
(spawn #:name 'static-content-server
(stop-when-reloaded)
(define url->path (make-url->path htdocs-path))
(on (web-request-get (id req) _ ,_)
@ -28,7 +28,7 @@
#:header (web-response-header #:mime-type (path->mime-type path))
(file->bytes path)))))
(actor #:name 'template-server
(spawn #:name 'template-server
(stop-when-reloaded)
(define url->path (make-url->path templates-path))
(during (api _ (observe (ui-template $name _)))

View File

@ -6,7 +6,7 @@
(require "protocol.rkt")
(require "duplicate.rkt")
(actor #:name 'trust-inference
(spawn #:name 'trust-inference
(stop-when-reloaded)
(during (grant $issuer $grantor $grantee $permission $delegable?)
@ -15,11 +15,11 @@
(during (permitted issuer grantor permission #t)
(assert (permitted issuer grantee permission delegable?)))))
(actor #:name 'grant-factory
(spawn #:name 'grant-factory
(stop-when-reloaded)
(on (message (create-resource
($ g (grant $issuer $grantor $grantee $permission $delegable?))))
(actor #:name g
(spawn #:name g
(on-start (log-info "~s grants ~s ~v~a"
grantor grantee permission (if delegable? ", delegably" "")))
(on-stop (log-info "~s revokes~a grant of ~v to ~s"
@ -33,10 +33,10 @@
(stop-when (message (delete-resource (account grantor))))
(stop-when (message (delete-resource (account grantee)))))))
(actor #:name 'request-factory
(spawn #:name 'request-factory
(stop-when-reloaded)
(on (message (create-resource ($ r (permission-request $the-issuer $grantee $permission))))
(actor #:name r
(spawn #:name r
(on-start (log-info "~s requests ~s from ~s" grantee permission the-issuer))
(assert r)
(stop-when-duplicate r)

View File

@ -6,6 +6,6 @@
))
(require "actor.rkt")
(require "hierarchy.rkt")
(provide (all-from-out "lang.rkt")
(provide (except-out (all-from-out "lang.rkt") actor)
(all-from-out "actor.rkt")
(all-from-out "hierarchy.rkt"))

View File

@ -43,7 +43,7 @@
[#f #f]
[pathstr
(supervise #:name (list 'reloader-supervisor pathstr)
(actor #:name 'reloader
(spawn #:name 'reloader
(reloader-mixin** module-path pathstr)))
#t]))

View File

@ -3,7 +3,7 @@
;; Vastly simplified compared to the available options in OTP
(provide supervise
supervise/actor)
supervise/spawn)
(require racket/exn)
(require "core.rkt")
@ -24,7 +24,7 @@
void
(lambda () expr ...)))]))
(define-syntax (supervise/actor stx)
(define-syntax (supervise/spawn stx)
(syntax-parse stx
[(_ (~or (~optional (~seq #:name name-expr) #:defaults ([name-expr #'#f])
#:name "#:name")