Update examples
This commit is contained in:
parent
1134ed0eff
commit
1f8bb56c69
|
@ -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))
|
||||
|
|
|
@ -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))]))
|
||||
|
|
|
@ -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))))
|
||||
|
||||
|
|
|
@ -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))))
|
||||
|
||||
|
|
|
@ -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])
|
||||
|
|
|
@ -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))
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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))
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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)))])))
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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))
|
||||
|
|
|
@ -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)))]
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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) '())]
|
||||
|
|
|
@ -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))
|
||||
|
|
|
@ -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))
|
||||
|
|
|
@ -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])
|
||||
|
||||
|
|
|
@ -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?)
|
||||
|
|
|
@ -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) {
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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))))
|
||||
|
|
|
@ -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))
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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))
|
||||
|
|
|
@ -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))))
|
||||
|
|
|
@ -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 _)))
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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"))
|
||||
|
|
|
@ -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]))
|
||||
|
||||
|
|
|
@ -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")
|
||||
|
|
Loading…
Reference in New Issue