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