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

First steps to an actual novy implementation

This commit is contained in:
Tony Garnock-Jones 2021-05-27 10:36:35 +02:00
parent 08c4980025
commit d1a1c967f7
16 changed files with 557 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
Makefile
View File

@ -1,5 +1,8 @@
PACKAGES=syndicate syndicate-examples
COLLECTS=syndicate syndicate-examples
# PACKAGES=syndicate syndicate-examples
# COLLECTS=syndicate syndicate-examples
PACKAGES=syndicate
COLLECTS=syndicate
all: setup

279
syndicate/actor.rkt Normal file
View File

@ -0,0 +1,279 @@
#lang racket/base
(provide parse-Ref
Ref->preserves)
(require racket/match)
(require (only-in racket/exn exn->string))
(require struct-defaults)
(require "rewrite.rkt")
(require "task.rkt")
(require "support/counter.rkt")
(struct entity (assert retract message sync))
(define-struct-defaults make-entity entity
(#:assert [entity-assert #f]
#:retract [entity-retract #f]
#:message [entity-message #f]
#:sync [entity-sync #f]))
(struct ref (relay target attenuation) #:transparent)
(define (parse-Ref r) (if (ref? r) r eof))
(define (Ref->preserves r) r)
(struct outbound-assertion (handle peer [established? #:mutable]))
(struct actor (id
[root #:mutable]
[exit-reason #:mutable] ;; #f -> running, #t -> terminated OK, exn -> error
[exit-hooks #:mutable])
#:transparent)
(struct facet (id
actor
parent
children
outbound
[shutdown-actions #:mutable]
[live? #:mutable]
[inert-check-preventers #:mutable])
#:transparent)
(struct turn (id
active-facet
[queues #:mutable]))
;;---------------------------------------------------------------------------
(define generate-actor-id (make-counter))
(define generate-turn-id (make-counter))
(define generate-handle (make-counter))
(define-logger syndicate/actor)
;;--------------------------------------------------------------------------
(define (make-actor boot-proc [initial-assertions (make-hash)])
(define ac (actor (generate-actor-id)
'uninitialized
#f
'()))
(set-actor-root! ac (make-facet ac #f initial-assertions))
(turn! (make-facet ac (actor-root ac))
(stop-if-inert-after boot-proc))
(log-syndicate/actor-debug "Created actor ~a" (actor-id ac))
ac)
(define (actor-add-exit-hook! ac hook)
(set-actor-exit-hooks! ac (cons hook (actor-exit-hooks ac))))
(define (actor-terminate! turn ac reason)
(when (not (actor-exit-reason ac))
(set-actor-exit-reason! ac reason)
(if (eq? reason #t)
(log-syndicate/actor-debug "Actor ~a terminated OK" (actor-id ac))
(log-syndicate/actor-error "Actor ~a terminated with exception:\n~a"
(actor-id ac)
(exn->string reason)))
(for [(h (in-list (reverse (actor-exit-hooks ac))))] (h turn))
(queue-task! (lambda () (turn! (actor-root ac)
(lambda (turn) (facet-terminate! turn (actor-root ac) #f))
#t)))))
;;---------------------------------------------------------------------------
(define (make-facet ac parent [initial-assertions (make-hash)])
(define f (facet (generate-actor-id)
ac
parent
(make-hasheq)
initial-assertions
'()
#t
0))
(when parent
(hash-set! (facet-children parent) f #t))
f)
(define (facet-on-stop! f action)
(set-facet-shutdown-actions! f (cons action (facet-shutdown-actions f))))
(define (facet-inert? f)
(and (hash-empty? (facet-children f))
(hash-empty? (facet-outbound f))
(zero? (facet-inert-check-preventers f))))
(define (facet-prevent-inert-check! f)
(define armed #t)
(set-facet-inert-check-preventers! (+ (facet-inert-check-preventers f) 1))
(lambda ()
(when armed
(set! armed #f)
(set-facet-inert-check-preventers! (- (facet-inert-check-preventers f) 1)))))
(define (facet-terminate! turn f orderly?)
(when (facet-live? f)
(set-facet-live?! f #f)
(define parent (facet-parent f))
(when parent (hash-remove! (facet-children parent) f))
(turn-call-with-facet turn f
(lambda (turn)
(for [(c (in-hash-keys (facet-children f)))]
(facet-terminate! turn c orderly?))
(when orderly?
(for [(h (in-list (reverse (facet-shutdown-actions f))))] (h turn)))
(for [(a (in-hash-values (facet-outbound f)))]
(turn-retract!* turn a))
(when orderly?
(queue-task!
(lambda ()
(if parent
(when (facet-inert? parent)
(turn! parent
(lambda (turn)
(facet-terminate! turn parent #t))))
(turn! (actor-root (facet-actor f))
(lambda (turn)
(actor-terminate! turn (facet-actor f) #t)))))))))))
;;---------------------------------------------------------------------------
(define (turn! f action [zombie-turn? #f])
(when (or zombie-turn? (and (not (actor-exit-reason (facet-actor f))) (facet-live? f)))
(let ((turn (turn (generate-turn-id) f (make-hasheq))))
(with-handlers ([exn? (lambda (e)
(turn! (actor-root (facet-actor f))
(lambda (turn)
(actor-terminate! turn (facet-actor f) e))))])
(action turn)
(for [((ff qq) (in-hash (turn-queues turn)))]
(queue-task! (lambda () (for [(a (in-list (reverse qq)))] (turn! ff a)))))
(set-turn-queues! turn #f)))))
(define (turn-call-with-facet outer-turn f action)
(let ((inner-turn (turn (generate-turn-id) f (turn-queues outer-turn))))
(action inner-turn)
(set-turn-queues! inner-turn #f)))
(define (turn-enqueue! turn f action)
(define qs (turn-queues turn))
(when (not qs) (error 'turn-enqueue! "Attempt to reuse a committed turn"))
(hash-update! qs f (lambda (actions) (cons action actions)) '()))
(define (turn-ref turn entity)
(ref (turn-active-facet turn) entity))
(define (turn-facet! turn boot-proc)
(let ((new-facet (make-facet (facet-actor (turn-active-facet turn)) (turn-active-facet turn))))
(turn-call-with-facet turn new-facet (stop-if-inert-after boot-proc))
new-facet))
(define (turn-stop! turn [f (turn-active-facet turn)] [continuation void])
(turn-enqueue! turn
(facet-parent f)
(lambda (turn)
(facet-terminate! turn f #t)
(continuation turn))))
(define (turn-spawn! turn boot-proc [initial-assertions (make-hash)])
(define f (turn-active-facet turn))
(define o (facet-outbound f))
(turn-enqueue! turn
f
(lambda (turn)
(define new-outbound (make-hash))
(for [(handle (in-hash-keys initial-assertions))]
(hash-set! new-outbound handle (hash-ref o handle))
(hash-remove! o handle))
(queue-task! (lambda () (make-actor boot-proc new-outbound))))))
(define (turn-stop-actor! turn)
(define ac (facet-actor (turn-active-facet turn)))
(turn-enqueue! turn (actor-root ac) (lambda (turn) (actor-terminate! turn ac #t))))
(define (turn-crash! turn exn)
(define ac (facet-actor (turn-active-facet turn)))
(turn-enqueue! turn (actor-root ac) (lambda (turn) (actor-terminate! turn ac exn))))
(define (turn-assert! turn peer assertion)
(define handle (generate-handle))
(turn-assert!* turn peer assertion handle)
handle)
(define (turn-assert!* turn peer assertion handle)
(match (run-rewrites (ref-attenuation peer) assertion)
[(? void?) (void)]
[rewritten
(define a (outbound-assertion handle peer #f))
(hash-set! (facet-outbound (turn-active-facet turn)) handle a)
(turn-enqueue! turn
(ref-relay peer)
(lambda (turn)
(set-outbound-assertion-established?! a #t)
(deliver (entity-assert (ref-target peer)) turn rewritten handle)))]))
(define (turn-retract! turn handle)
(when handle
(define a (hash-ref (facet-outbound (turn-active-facet turn)) handle #f))
(when a (turn-retract!* turn a))))
(define (turn-replace! turn peer old-handle assertion)
(define new-handle (if (void? assertion) #f (turn-assert! turn peer assertion)))
(turn-retract! turn old-handle)
new-handle)
(define (turn-retract!* turn a)
(hash-remove! (facet-outbound (turn-active-facet turn)) (outbound-assertion-handle a))
(turn-enqueue! turn
(ref-relay (outbound-assertion-peer a))
(lambda (turn)
(when (outbound-assertion-established? a)
(set-outbound-assertion-established?! a #f)
(deliver (entity-retract (ref-target (outbound-assertion-peer a)))
turn
(outbound-assertion-handle a))))))
(define (turn-sync! turn peer k)
(turn-sync!* turn peer (turn-ref turn (make-entity #:message k))))
(define (turn-sync!* turn peer-to-sync-with peer-k)
(turn-enqueue! turn
(ref-relay peer-to-sync-with)
(lambda (turn)
(deliver (or (entity-sync (ref-target peer-to-sync-with))
(lambda (turn peer-k) (turn-message! turn peer-k #t)))
turn
peer-k))))
(define (turn-message! turn peer assertion)
(match (run-rewrites (ref-attenuation peer) assertion)
[(? void?) (void)]
[rewritten
(turn-enqueue! turn
(ref-relay peer)
(lambda (turn)
(deliver (entity-message (ref-target peer)) turn rewritten)))]))
(define (turn-freshen turn action)
(when (turn-queues turn) (error 'turn-freshen "Attempt to freshen a non-stale turn"))
(turn! (turn-active-facet turn) action))
;;---------------------------------------------------------------------------
(define (stop-if-inert-after action)
(lambda (turn)
(action turn)
(turn-enqueue! turn
(turn-active-facet turn)
(lambda (turn)
(define f (turn-active-facet turn))
(when (or (and (facet-parent f) (not (facet-live? (facet-parent f))))
(facet-inert? f))
(turn-stop! turn))))))
(define (deliver maybe-proc . args)
(when maybe-proc
(apply maybe-proc args)))

32
syndicate/info.rkt
View File

@ -1,20 +1,26 @@
#lang setup/infotab
(define collection "syndicate")
(define deps '("rfc6455"
(define deps '(
"base"
"data-lib"
"net-lib"
"web-server-lib"
"profile-lib"
"htdp-lib"
"gui-lib"
"pict-lib"
"db-lib"
"sgl"
"preserves"
"struct-defaults"
"auxiliary-macro-context"
"bitsyntax"
"preserves"))
;; "data-lib"
;; "htdp-lib"
;; "net-lib"
;; "profile-lib"
;; "bitsyntax"
;; "db-lib"
;; "gui-lib"
;; "pict-lib"
;; "rfc6455"
;; "sgl"
;; "web-server-lib"
))
(define build-deps '("rackunit-lib"))
(define pre-install-collection "private/install.rkt")

22
syndicate/private/install.rkt Normal file
View File

@ -0,0 +1,22 @@
#lang racket/base
(provide pre-installer)
(require racket/runtime-path)
(require preserves-schema/bin/preserves-schema-rkt)
(require (only-in racket/file delete-directory/files))
(define (pre-installer _collects-path syndicate-path)
(define output-directory (build-path syndicate-path "schemas/gen"))
(delete-directory/files output-directory)
(batch-compile #:inputs (list (build-path syndicate-path "schemas/**.prs"))
#:additional-modules (hash '(Actor) 'syndicate/actor)
#:output-directory output-directory))
(define-runtime-path syndicate-path "..")
(define (regenerate!)
(void (pre-installer 'not-bothering-to-figure-this-out-since-we-do-not-need-it
syndicate-path)))
(module+ main
(regenerate!))

97
syndicate/rewrite.rkt Normal file
View File

@ -0,0 +1,97 @@
#lang racket/base
(provide run-rewrites)
(require racket/match)
(require racket/dict)
(require preserves)
(require "schemas/gen/sturdy.rkt")
(define (match-Pattern p v)
(define bindings (make-hasheq))
(define (walk p v)
(match p
[(Pattern-PDiscard _) #t]
[(Pattern-PAtom (PAtom-Boolean)) (boolean? v)]
[(Pattern-PAtom (PAtom-ByteString)) (bytes? v)]
[(Pattern-PAtom (PAtom-Double)) (flonum? v)]
[(Pattern-PAtom (PAtom-Float)) (float? v)]
[(Pattern-PAtom (PAtom-SignedInteger)) (integer? v)]
[(Pattern-PAtom (PAtom-String)) (string? v)]
[(Pattern-PAtom (PAtom-Symbol)) (symbol? v)]
[(Pattern-PEmbedded (PEmbedded)) (embedded? v)]
[(Pattern-PBind (PBind n p)) (and (walk p v) (begin (hash-set! bindings n v) #t))]
[(Pattern-PAnd ps) (andmap (lambda (p) (walk p v)) ps)]
[(Pattern-PNot p)
(let ((saved bindings))
(set! bindings (make-hasheq))
(let ((result (walk p v)))
(set! bindings saved)
(not result)))]
[(Pattern-Lit (Lit expected)) (preserve=? expected v)]
[(Pattern-PCompound (PCompound (ConstructorSpec-CRec (CRec label arity)) members))
(match v
[(record (== label preserve=?) fields)
(and (= (length fields) arity)
(for/and [((key pp) (in-hash members))]
(and (exact-integer? key) (walk pp (list-ref fields key)))))]
[_ #f])]
[(Pattern-PCompound (PCompound (ConstructorSpec-CArr (CArr arity)) members))
(and (list? v)
(= (length v) arity)
(for/and [((key pp) (in-hash members))]
(and (exact-integer? key) (walk pp (list-ref v key)))))]
[(Pattern-PCompound (PCompound (ConstructorSpec-CDict (CDict)) members))
(and (dict? v)
(for/and [((key pp) (in-hash members))]
(define vv (hash-ref v key (void)))
(and (not (void? vv)) (walk pp vv))))]))
(and (walk p v) bindings))
(define (instantiate-Template t bindings)
(let walk ((t t))
(match t
[(Template-TRef (TRef name))
(hash-ref bindings name (lambda () (error 'instantiate-Template "Missing binding: ~v" name)))]
[(Template-Lit (Lit v)) v]
[(Template-TCompound (TCompound (ConstructorSpec-CRec (CRec label arity)) members))
(record label
(for/list [(i (in-range 0 arity))]
(walk (hash-ref members i (lambda () (error 'instantiate-Template
"Missing record field key ~v" i))))))]
[(Template-TCompound (TCompound (ConstructorSpec-CArr (CArr arity)) members))
(for/list [(i (in-range 0 arity))]
(walk (hash-ref members i (lambda () (error 'instantiate-Template
"Missing array key ~v" i)))))]
[(Template-TCompound (TCompound (ConstructorSpec-CDict (CDict)) members))
(for/hash [((key tt) (in-hash members))]
(values key (walk tt)))])))
(define (rewrite r v)
(define bindings (match-Pattern (Rewrite-pattern r) v))
(if bindings
(instantiate-Template (Rewrite-template r) bindings)
(void)))
(define (examine-alternatives caveat v)
(match caveat
[(Caveat-Alts (Alts alts))
(let loop ((alts alts))
(match alts
['() (void)]
[(cons alt remaining) (match (rewrite alt v)
[(? void?) (loop remaining)]
[rewritten rewritten])]))]
[(Caveat-Rewrite r)
(rewrite r v)]))
(define (run-rewrites attenuation v)
(let loop ((stages attenuation) (v v))
(match stages
['() v]
[(cons stage remaining) (match (examine-alternatives stage v)
[(? void?) (void)]
[rewritten (loop remaining rewritten)])])))

1
syndicate/schemas/.gitignore vendored Normal file
View File

@ -0,0 +1 @@
gen/

9
syndicate/schemas/box-protocol.prs Normal file
View File

@ -0,0 +1,9 @@
version 1 .
embeddedType Actor.Ref .
BoxState = <BoxState @value int>.
SetBox = <SetBox @value int>.
; BoxCap = BoxState / <Observe =SetBox @observer embedded>.
; ClientCap = SetBox / <Observe =BoxState @observer embedded>.
.

9
syndicate/schemas/dataspace.prs Normal file
View File

@ -0,0 +1,9 @@
version 1 .
embeddedType Actor.Ref .
;As implemented
Observe = <Observe @label symbol @observer embedded>.
; ;As will be implemented soon
; Observe = <Observe @pattern Pattern @observer embedded>.
.

5
syndicate/schemas/gatekeeper.prs Normal file
View File

@ -0,0 +1,5 @@
version 1 .
embeddedType Actor.Ref .
Resolve = <resolve @sturdyref sturdy.SturdyRef @observer embedded>.
Bind = <bind @oid any @key bytes @target embedded>.

14
syndicate/schemas/protocol.prs Normal file
View File

@ -0,0 +1,14 @@
version 1 .
embeddedType sturdy.WireRef .
Assertion = any .
Handle = int .
Event = Assert / Retract / Message / Sync .
Oid = int .
Turn = [TurnEvent ...].
TurnEvent = [@oid Oid @event Event].
Assert = <assert @assertion Assertion @handle Handle>.
Retract = <retract @handle Handle>.
Message = <message @body Assertion>.
Sync = <sync @peer embedded>.

14
syndicate/schemas/secure-chat-protocol.prs Normal file
View File

@ -0,0 +1,14 @@
version 1 .
embeddedType Actor.Ref .
UserId = int .
Join = <joinedUser @uid UserId @handle embedded>.
NickClaim = <claimNick @uid UserId @name string @k embedded>.
UserInfo = <user @uid UserId @name string>.
Says = <says @who UserId @what string>.
NickConflict = <nickConflict>.

5
syndicate/schemas/simple-chat-protocol.prs Normal file
View File

@ -0,0 +1,5 @@
version 1 .
embeddedType Actor.Ref .
Present = <Present @username string>.
Says = <Says @who string @what string>.

43
syndicate/schemas/sturdy.prs Normal file
View File

@ -0,0 +1,43 @@
version 1 .
; Each Attenuation is a stage. The sequence of Attenuations is run RIGHT-TO-LEFT.
; That is, the newest Attenuations are at the right.
SturdyRef = <ref @oid any @caveatChain [Attenuation ...] @sig bytes>.
; An individual Attenuation is run RIGHT-TO-LEFT.
; That is, the newest Caveats are at the right.
Attenuation = [Caveat ...].
; embodies 1st-party caveats over assertion structure, but nothing else
; can add 3rd-party caveats and richer predicates later
Caveat = Rewrite / Alts .
Rewrite = <rewrite @pattern Pattern @template Template>.
Alts = <or @alternatives [Rewrite ...]>.
Oid = int .
WireRef = @mine [0 @oid Oid] / @yours [1 @oid Oid @attenuation Caveat ...].
;---------------------------------------------------------------------------
ConstructorSpec = CRec / CArr / CDict .
CRec = <rec @label any @arity int>.
CArr = <arr @arity int>.
CDict = <dict>.
Lit = <lit @value any>.
Pattern = PDiscard / PAtom / PEmbedded / PBind / PAnd / PNot / Lit / PCompound .
PDiscard = <_>.
PAtom = =Boolean / =Float / =Double / =SignedInteger / =String / =ByteString / =Symbol .
PEmbedded = =Embedded .
PBind = <bind @name symbol @pattern Pattern>.
PAnd = <and @patterns [Pattern ...]>.
PNot = <not @pattern Pattern>.
PCompound = <compound @ctor ConstructorSpec @members PCompoundMembers>.
PCompoundMembers = { any: Pattern ...:... }.
Template = TRef / Lit / TCompound .
TRef = <ref @name symbol>.
TCompound = <compound @ctor ConstructorSpec @members TCompoundMembers>.
TCompoundMembers = { any: Template ...:... }.

4
syndicate/schemas/worker.prs Normal file
View File

@ -0,0 +1,4 @@
version 1 .
embeddedType Actor.Ref .
Instance = <Instance @name string @argument any>.

10
syndicate/support/counter.rkt Normal file
View File

@ -0,0 +1,10 @@
#lang racket/base
(provide make-counter)
(define (make-counter [start-value 0])
(define next-value start-value)
(lambda ()
(let ((v next-value))
(set! next-value (+ v 1))
v)))

21
syndicate/task.rkt Normal file
View File

@ -0,0 +1,21 @@
#lang racket/base
(provide queue-task!)
(require (only-in racket/exn exn->string))
(define-logger syndicate/task)
(define task-runner
(thread (lambda ()
(with-handlers ([exn? handle-unexpected-task-runner-termination])
(let loop ()
((thread-receive))
(loop))))))
(define (handle-unexpected-task-runner-termination e)
(log-syndicate/task-error "Task runner terminated unexpectedly!\n~a" (exn->string e))
(exit 1))
(define (queue-task! thunk)
(thread-send task-runner thunk))