syndicate-lang
/
syndicate-rkt
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

First sketch of `quit-dataspace!`.

This commit is contained in:
Tony Garnock-Jones 2018-05-01 20:58:43 +01:00
parent 896cfe2498
commit 869a495392
3 changed files with 42 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
syndicate/dataspace.rkt
View File

@ -21,6 +21,7 @@
facet?
facet-actor
facet-live?
field-handle ;; TODO: shouldn't be provided - inline syntax.rkt??
field-handle?

26
syndicate/examples/chat-server-nested-dataspace.rkt Normal file
View File

@ -0,0 +1,26 @@
#lang imperative-syndicate
(require/activate imperative-syndicate/drivers/tcp)
(require racket/format)
(message-struct speak (who what))
(assertion-struct present (who))
(dataspace
(spawn #:name 'chat-server
(during/spawn (inbound (tcp-connection $id (tcp-listener 5999)))
#:name (list 'chat-connection id)
(assert (outbound (tcp-accepted id)))
(let ((me (gensym 'user)))
(assert (present me))
(on (message (inbound (tcp-in-line id $bs)))
(match bs
[#"/quit" (stop-current-facet)]
[#"/stop-server" (quit-dataspace!)]
[_ (send! (speak me (bytes->string/utf-8 bs)))])))
(during (present $user)
(on-start (send! (outbound (tcp-out id (string->bytes/utf-8 (~a user " arrived\n"))))))
(on-stop (send! (outbound (tcp-out id (string->bytes/utf-8 (~a user " left\n"))))))
(on (message (speak user $text))
(send!
(outbound (tcp-out id (string->bytes/utf-8 (~a user " says '" text "'\n"))))))))))

19
syndicate/relay.rkt
View File

@ -1,10 +1,10 @@
#lang racket/base
;; Cross-layer relaying between adjacent dataspaces
;; TODO: protocol for shutdown of a dataspace
;; TODO: protocol for *clean* shutdown of a dataspace
(provide (struct-out inbound)
(struct-out outbound)
quit-dataspace!
dataspace)
(require racket/match)
@ -22,8 +22,13 @@
(struct inbound (assertion) #:prefab)
(struct outbound (assertion) #:prefab)
(struct *quit-dataspace* () #:transparent)
;; TODO: inbound^n, outbound^n -- protocol/standard-relay, iow
(define (quit-dataspace!)
(send! (*quit-dataspace*)))
(define-syntax (dataspace stx)
(syntax-parse stx
[(_ name:name form ...)
@ -31,14 +36,16 @@
(let ((ds-name name.N))
(spawn #:name ds-name
(define outer-facet (current-facet))
(begin/dataflow (void)) ;; eww. dummy endpoint to keep the root facet alive
(define (schedule-inner!)
(push-script!
(facet-actor outer-facet)
(lambda ()
(with-current-facet [outer-facet]
(defer-turn! (lambda ()
(when (run-scripts! inner-ds)
(schedule-inner!))))))))
(when (facet-live? outer-facet)
(defer-turn! (lambda ()
(when (run-scripts! inner-ds)
(schedule-inner!)))))))))
(define inner-ds (make-dataspace
(lambda ()
(schedule-script!
@ -92,6 +99,10 @@
#t
(lambda () (values (observe x) i)))))))
(on (message (*quit-dataspace*))
(with-current-facet [outer-facet]
(stop-current-facet)))
(on (retracted (observe (inbound $x)))
;; (log-info "~a (retracted (observe (inbound ~v)))" inner-actor x)
(with-current-facet [outer-facet]