Compare commits
4 Commits
main
...
naiverouti
| Author | SHA1 | Date |
|---|---|---|
Tony Garnock-Jones
|
7c22d439ec | |
|
Tony Garnock-Jones
|
187d4affa8 | |
|
Tony Garnock-Jones
|
dc54c31ab2 | |
|
Tony Garnock-Jones
|
6dc52115e3 |
|
|
@ -1,579 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
;; TODO: syntax-id-rules: raise-syntax-error on set!, pointing users
|
||||
;; to the #:update pseudo-action.
|
||||
|
||||
;; TODO: enforce presence of #:arguments, and enforce that it declares
|
||||
;; all the free variables in the actor.
|
||||
|
||||
(provide actor
|
||||
observe-gestalt
|
||||
observe-subscribers
|
||||
observe-advertisers
|
||||
advertise
|
||||
subscribe
|
||||
for/advertise
|
||||
for/subscribe
|
||||
define-transition
|
||||
begin-transition
|
||||
noop-transition)
|
||||
|
||||
;; (require (for-syntax racket/pretty))
|
||||
;; (require (for-syntax racket/trace))
|
||||
|
||||
(require racket/set)
|
||||
(require racket/match)
|
||||
|
||||
(require (for-syntax racket/match))
|
||||
(require (for-syntax racket/list))
|
||||
(require (for-syntax racket/base))
|
||||
(require (for-syntax syntax/stx))
|
||||
|
||||
(require racket/stxparam)
|
||||
(require racket/splicing)
|
||||
|
||||
(require "core.rkt")
|
||||
(require "gestalt.rkt")
|
||||
|
||||
(define-syntax (actor stx)
|
||||
(syntax-case stx ()
|
||||
[(_actor forms ...)
|
||||
(analyze-actor #'_actor #'(forms ...))]))
|
||||
|
||||
(define-syntax (observe-gestalt stx) (raise-syntax-error #f "Use of observe-gestalt outside actor form" stx))
|
||||
(define-syntax (observe-subscribers stx) (raise-syntax-error #f "Use of observe-subscribers outside actor form" stx))
|
||||
(define-syntax (observe-advertisers stx) (raise-syntax-error #f "Use of observe-advertisers outside actor form" stx))
|
||||
(define-syntax (advertise stx) (raise-syntax-error #f "Use of advertise outside actor form" stx))
|
||||
(define-syntax (subscribe stx) (raise-syntax-error #f "Use of subscribe outside actor form" stx))
|
||||
(define-syntax (for/advertise stx) (raise-syntax-error #f "Use of for/advertise outside actor form" stx))
|
||||
(define-syntax (for/subscribe stx) (raise-syntax-error #f "Use of for/subscribe outside actor form" stx))
|
||||
|
||||
(define-syntax-parameter update-state-struct #f)
|
||||
(define-syntax-parameter match-state #f)
|
||||
(define-syntax-parameter update-gestalt #f)
|
||||
|
||||
(define-syntax-rule (define-transition head tail ...)
|
||||
(define head (begin-transition tail ...)))
|
||||
|
||||
(define-syntax (begin-transition stx)
|
||||
(syntax-case stx ()
|
||||
[(_ forms ...)
|
||||
(let ()
|
||||
(define result (accumulate-actions (gensym 'begin-transition) '() '() #'(forms ...)))
|
||||
;; (pretty-print `(result ,(syntax->datum result)))
|
||||
result)]))
|
||||
|
||||
(define (noop-transition state)
|
||||
(transition state '()))
|
||||
|
||||
(begin-for-syntax
|
||||
|
||||
(define-syntax-rule (define-temporaries [tempvar basestx] ...)
|
||||
(match-define (list tempvar ...) (generate-temporaries (list basestx ...))))
|
||||
|
||||
(define (identifier-append ctxt . pieces)
|
||||
(and ctxt (datum->syntax ctxt
|
||||
(string->symbol
|
||||
(apply string-append
|
||||
(for/list [(piece pieces)]
|
||||
(symbol->string (if (syntax? piece) (syntax->datum piece) piece))))))))
|
||||
|
||||
(define (analyze-pattern pat-stx)
|
||||
(syntax-case pat-stx ($ quasiquote unquote quote)
|
||||
;; Extremely limited support for quasiquoting and quoting
|
||||
[(quasiquote (unquote p)) (analyze-pattern #'p)]
|
||||
[(quasiquote (p ...)) (analyze-pattern #'(list (quasiquote p) ...))]
|
||||
[(quasiquote p) (values #''p #''p #''p '())]
|
||||
[(quote p) (values #''p #''p #''p '())]
|
||||
|
||||
[($ v)
|
||||
(values #'(?!)
|
||||
#'?
|
||||
#'v
|
||||
(list #'v))]
|
||||
[($ v p)
|
||||
(let ()
|
||||
(define-values (pr g m bs) (analyze-pattern #'p))
|
||||
(when (not (null? bs))
|
||||
(raise-syntax-error #f "nested bindings not supported" pat-stx))
|
||||
(values #`(?! #,pr)
|
||||
g
|
||||
#`(and v #,m)
|
||||
(list #'v)))]
|
||||
[(ctor p ...)
|
||||
(let ()
|
||||
(define parts (if (identifier? #'ctor) #'(p ...) #'(ctor p ...)))
|
||||
(define-values (pr g m bs)
|
||||
(for/fold [(pr '()) (g '()) (m '()) (bs '())] [(p (syntax->list parts))]
|
||||
(define-values (pr1 g1 m1 bs1) (analyze-pattern p))
|
||||
(values (cons pr1 pr)
|
||||
(cons g1 g)
|
||||
(cons m1 m)
|
||||
(append bs1 bs))))
|
||||
(if (identifier? #'ctor)
|
||||
(values (cons #'ctor (reverse pr))
|
||||
(cons #'ctor (reverse g))
|
||||
(cons #'ctor (reverse m))
|
||||
bs)
|
||||
(values (reverse pr)
|
||||
(reverse g)
|
||||
(reverse m)
|
||||
bs)))]
|
||||
[non-pair
|
||||
(if (and (identifier? #'non-pair)
|
||||
(free-identifier=? #'non-pair #'?))
|
||||
(values #'?
|
||||
#'?
|
||||
#'_
|
||||
'())
|
||||
(values #'non-pair
|
||||
#'non-pair
|
||||
#'(== non-pair)
|
||||
'()))]))
|
||||
|
||||
(struct observer
|
||||
(condition level meta-level presence-name set-name set-exp added-name removed-name)
|
||||
#:transparent)
|
||||
|
||||
(struct participator (condition meta-level) #:transparent)
|
||||
|
||||
(define (analyze-actor actor-form-head-stx forms-stx)
|
||||
(define actor-name #f)
|
||||
|
||||
;; (Listof Identifier)
|
||||
;; Names for actor state values. User-supplied identifiers.
|
||||
(define statevars '())
|
||||
|
||||
;; (Listof Identifier)
|
||||
;; Temporaries usable for internal bindings of state values. Computed, fresh identifiers.
|
||||
(define statetemps '())
|
||||
|
||||
;; (Listof Syntax)
|
||||
;; Fragments computing gestalt of the actor. Each is in transition context.
|
||||
;; State bindings and body definitions are in scope.
|
||||
(define gestalt-updaters '())
|
||||
|
||||
;; (Listof Syntax)
|
||||
;; Fragments used to assemble gestalt of the actor. Each is in expression context.
|
||||
;; State bindings and body definitions are in scope.
|
||||
(define gestalt-fragments '())
|
||||
|
||||
;; (Listof (Syntax -> Syntax))
|
||||
;; Sequence of functions generating expressions yielding
|
||||
;; transition-functions for responding to events.
|
||||
;; State bindings and body definitions are in scope.
|
||||
(define event-handlers '())
|
||||
|
||||
;; (Listof Identifier)
|
||||
;; Names for body-definitions representing actions to take on actor bootup.
|
||||
(define action-ids '())
|
||||
|
||||
;; (Listof Syntax)
|
||||
;; Body definition forms.
|
||||
(define body-forms '())
|
||||
|
||||
(define-syntax-rule (push! var val) (set! var (cons val var)))
|
||||
(define-syntax-rule (push-many! var vals ...) (set! var (append vals ... var)))
|
||||
|
||||
(define (push-statevar! statevar-stx statetemp-stx stateexp-stx)
|
||||
(push! statevars statevar-stx)
|
||||
(push! statetemps statetemp-stx)
|
||||
(push! body-forms #`(define #,statetemp-stx #,stateexp-stx)))
|
||||
|
||||
(define (walk-forms forms-stx)
|
||||
(syntax-case forms-stx (observe-gestalt
|
||||
observe-subscribers
|
||||
observe-advertisers
|
||||
advertise
|
||||
subscribe
|
||||
for/advertise
|
||||
for/subscribe)
|
||||
[() (build-result)]
|
||||
|
||||
[(#:name name rest ...) ;; TODO: named processes
|
||||
(begin (when actor-name (raise-syntax-error #f "duplicate actor #:name" forms-stx))
|
||||
(unless (identifier? #'name)
|
||||
(raise-syntax-error #f "actor #:name must be an identifier" #'name))
|
||||
(set! actor-name #'name)
|
||||
(walk-forms #'(rest ...)))]
|
||||
|
||||
[(#:arguments [arg ...] rest ...) ;; TODO arguments
|
||||
(walk-forms #'(rest ...))]
|
||||
|
||||
[(#:state [statevar stateexp] rest ...)
|
||||
(begin (define-temporaries [statetemp #'statevar])
|
||||
(push-statevar! #'statevar statetemp #'stateexp)
|
||||
(walk-forms #'(rest ...)))]
|
||||
|
||||
[((observe-gestalt g [pattern body ...] ...) rest ...)
|
||||
(begin (analyze-general-observer! #'g #'([pattern (begin-transition body ...)] ...))
|
||||
(walk-forms #'(rest ...)))]
|
||||
|
||||
[((observe-subscribers pat body ...) rest ...)
|
||||
(begin (analyze-observation! #'pat #'(body ...) #t)
|
||||
(walk-forms #'(rest ...)))]
|
||||
|
||||
[((observe-advertisers pat body ...) rest ...)
|
||||
(begin (analyze-observation! #'pat #'(body ...) #f)
|
||||
(walk-forms #'(rest ...)))]
|
||||
|
||||
[((advertise pat body ...) rest ...)
|
||||
(begin (analyze-participation! #'pat #'(body ...) #t)
|
||||
(walk-forms #'(rest ...)))]
|
||||
|
||||
[((subscribe pat body ...) rest ...)
|
||||
(begin (analyze-participation! #'pat #'(body ...) #f)
|
||||
(walk-forms #'(rest ...)))]
|
||||
|
||||
[((for/advertise [loopspec ...] pat body ...) rest ...)
|
||||
(begin (analyze-group-participation! #'(loopspec ...) #'pat #'(body ...) #t)
|
||||
(walk-forms #'(rest ...)))]
|
||||
|
||||
[((for/subscribe [loopspec ...] pat body ...) rest ...)
|
||||
(begin (analyze-group-participation! #'(loopspec ...) #'pat #'(body ...) #f)
|
||||
(walk-forms #'(rest ...)))]
|
||||
|
||||
[(expr rest ...)
|
||||
(syntax-case (expand-in-context (gensym 'actor-initialization) #'expr) ()
|
||||
[(head inner-rest ...)
|
||||
(if (or (free-identifier=? #'head #'begin)
|
||||
(free-identifier=? #'head #'begin-transition))
|
||||
(walk-forms #'(inner-rest ... rest ...))
|
||||
(if (ormap (lambda (i) (free-identifier=? #'head i))
|
||||
(syntax->list #'(define-values define-syntaxes begin-for-syntax
|
||||
module module*
|
||||
#%module-begin
|
||||
#%require #%provide)))
|
||||
(begin (push! body-forms #'expr)
|
||||
(walk-forms #'(rest ...)))
|
||||
(begin (push-action! #'expr)
|
||||
(walk-forms #'(rest ...)))))]
|
||||
[non-pair-syntax
|
||||
(begin (push-action! #'expr)
|
||||
(walk-forms #'(rest ...)))])]))
|
||||
|
||||
(define (defbinding name-stx init-name-stx init-exp)
|
||||
(list #`(define #,init-name-stx #,init-exp)))
|
||||
|
||||
(define-syntax-rule (analyze-body* self body-stx struct-type o [keyword accessor fieldname] ...)
|
||||
(syntax-case body-stx ()
|
||||
[(keyword v rest (... ...))
|
||||
(if (accessor o)
|
||||
(raise-syntax-error #f (format "duplicate ~a clause" 'keyword) body-stx)
|
||||
(self #'(rest (... ...)) (struct-copy struct-type o [fieldname #'v])))]
|
||||
...
|
||||
[other (values o #'other)]))
|
||||
|
||||
(define (analyze-observer-body body-stx o)
|
||||
(analyze-body* analyze-observer-body body-stx observer o
|
||||
[#:when observer-condition condition]
|
||||
[#:level observer-level level]
|
||||
[#:meta-level observer-meta-level meta-level]
|
||||
[#:presence observer-presence-name presence-name]
|
||||
[#:name observer-set-name set-name]
|
||||
[#:set observer-set-exp set-exp]
|
||||
[#:added observer-added-name added-name]
|
||||
[#:removed observer-removed-name removed-name]))
|
||||
|
||||
(define (analyze-participator-body body-stx p)
|
||||
(analyze-body* analyze-participator-body body-stx participator p
|
||||
[#:when participator-condition condition]
|
||||
[#:meta-level participator-meta-level meta-level]))
|
||||
|
||||
(define (analyze-general-observer! gestalt-stx event-handler-clauses-stx)
|
||||
(define-temporaries
|
||||
[gestalt-name0 #'general]
|
||||
[gestalt-init gestalt-stx])
|
||||
(define gestalt-name (identifier-append gestalt-stx 'gestalt: gestalt-name0))
|
||||
(push-statevar! gestalt-name gestalt-init #'#f)
|
||||
|
||||
(push! gestalt-updaters
|
||||
#`(begin
|
||||
(define #,gestalt-init (label-gestalt #,gestalt-stx #t))
|
||||
#:update [#,gestalt-name #,gestalt-init]))
|
||||
|
||||
(push! gestalt-fragments gestalt-name)
|
||||
|
||||
(push! event-handlers
|
||||
(lambda (e-stx)
|
||||
#`(match-state state
|
||||
(let ((filtered-event (filter-event #,e-stx #,gestalt-name)))
|
||||
(if (not filtered-event)
|
||||
#f
|
||||
((match filtered-event
|
||||
#,@event-handler-clauses-stx
|
||||
[_ #f])
|
||||
state)))))))
|
||||
|
||||
(define (analyze-observation! pat-stx body-stx pub?)
|
||||
(define-values (o remaining-stx)
|
||||
(analyze-observer-body body-stx (observer #f #f #f #f #f #f #f #f)))
|
||||
(match-define
|
||||
(observer condition level meta-level presence-name set-name set-exp added-name removed-name)
|
||||
o)
|
||||
(when (and (not set-name) (or set-exp added-name removed-name))
|
||||
(define stx (or set-exp added-name removed-name))
|
||||
(raise-syntax-error #f "#:name is required when using #:set, #:added and/or #:removed" stx))
|
||||
(define base-temp-name (or set-name presence-name))
|
||||
(define-temporaries
|
||||
[presence-init presence-name]
|
||||
[set-init set-name]
|
||||
[set-temp set-name]
|
||||
[projector-init base-temp-name]
|
||||
[gestalt-init base-temp-name])
|
||||
(define projector-name (identifier-append set-name 'projector: set-name))
|
||||
(define gestalt-name (identifier-append base-temp-name 'gestalt: base-temp-name))
|
||||
(define-values (projector-stx gestalt-stx matcher-stx binders) (analyze-pattern pat-stx))
|
||||
|
||||
(define using-presence? (if presence-name #t #f))
|
||||
(define using-set? (if (or set-name added-name removed-name) #t #f))
|
||||
|
||||
(when using-presence?
|
||||
(push-statevar! presence-name presence-init #'#f))
|
||||
(when using-set?
|
||||
(push-statevar! set-name set-init #'(set))
|
||||
(push-statevar! projector-name projector-init #'#f))
|
||||
|
||||
(define gestalt-name-available? (or using-presence? using-set?))
|
||||
(when gestalt-name-available?
|
||||
(push-statevar! gestalt-name gestalt-init #'#f))
|
||||
|
||||
(push! event-handlers
|
||||
(lambda (e-stx)
|
||||
#`(match #,e-stx
|
||||
[(routing-update g)
|
||||
(begin-transition
|
||||
#,@(if using-presence?
|
||||
#`(#:update [#,presence-name
|
||||
(not (gestalt-empty?
|
||||
(gestalt-filter g #,gestalt-name)))])
|
||||
#'())
|
||||
#,@(if using-set?
|
||||
#`((define #,set-temp
|
||||
#,(if set-exp
|
||||
#`(for/set [(e (in-set
|
||||
(gestalt-project/keys g
|
||||
#,projector-name)))]
|
||||
(match-define (list #,@binders) e)
|
||||
#,set-exp)
|
||||
#`(gestalt-project/keys g #,projector-name)))
|
||||
#,@(if added-name
|
||||
#`((define #,added-name (set-subtract #,set-temp
|
||||
#,set-name)))
|
||||
#'())
|
||||
#,@(if removed-name
|
||||
#`((define #,removed-name (set-subtract #,set-name
|
||||
#,set-temp)))
|
||||
#'())
|
||||
#,@(if set-name
|
||||
#`(#:update [#,set-name #,set-temp])
|
||||
#'()))
|
||||
#'())
|
||||
#,@remaining-stx)]
|
||||
[_ noop-transition])))
|
||||
|
||||
(when gestalt-name-available?
|
||||
(push! gestalt-updaters
|
||||
#`(begin
|
||||
(define #,projector-init
|
||||
(#,(if pub? #'project-subs #'project-pubs) #,projector-stx
|
||||
#:level #,(or level 0) #:meta-level #,(or meta-level 0)))
|
||||
(define #,gestalt-init (projection->gestalt #,projector-init))
|
||||
#,@(if using-set?
|
||||
#`(#:update [#,projector-name #,projector-init])
|
||||
#'())
|
||||
#,@(if gestalt-name-available?
|
||||
#`(#:update [#,gestalt-name #,gestalt-init])
|
||||
#'()))))
|
||||
|
||||
(push! gestalt-fragments
|
||||
(let ((g (if gestalt-name-available?
|
||||
gestalt-name
|
||||
#`(#,(if pub? #'pub #'sub) #,gestalt-stx
|
||||
#:level #,(+ 1 (or level 0)) #:meta-level #,(or meta-level 0)))))
|
||||
(if condition
|
||||
#`(if #,condition #,g (gestalt-empty))
|
||||
g))))
|
||||
|
||||
(define (analyze-participation! pat-stx body-stx pub?)
|
||||
(define-values (p remaining-stx) (analyze-participator-body body-stx (participator #f #f)))
|
||||
(match-define (participator condition meta-level) p)
|
||||
(define-temporaries [gestalt-name pat-stx])
|
||||
(define-values (projector-stx gestalt-stx matcher-stx binders) (analyze-pattern pat-stx))
|
||||
|
||||
(push! gestalt-updaters
|
||||
#`(define #,gestalt-name (#,(if pub? #'pub #'sub) #,gestalt-stx
|
||||
#:meta-level #,(or meta-level 0))))
|
||||
|
||||
(push! gestalt-fragments
|
||||
(if condition
|
||||
#`(if #,condition #,gestalt-name (gestalt-empty))
|
||||
gestalt-name))
|
||||
|
||||
(when (not (stx-null? remaining-stx))
|
||||
(push! event-handlers
|
||||
(lambda (e-stx)
|
||||
#`(match #,e-stx
|
||||
[(message #,matcher-stx (== #,(or meta-level 0)) #,pub?)
|
||||
(begin-transition #,@remaining-stx)]
|
||||
[_ noop-transition])))))
|
||||
|
||||
(define (analyze-group-participation! loopspecs-stx pat-stx body-stx pub?)
|
||||
(define-values (p remaining-stx) (analyze-participator-body body-stx (participator #f #f)))
|
||||
(match-define (participator condition meta-level) p)
|
||||
(define-temporaries
|
||||
[projector-name pat-stx]
|
||||
[gestalt-name pat-stx])
|
||||
(define-values (projector-stx gestalt-stx matcher-stx binders) (analyze-pattern pat-stx))
|
||||
(unless (stx-null? remaining-stx)
|
||||
(raise-syntax-error #f
|
||||
"for/advertise, and for/subscribe cannot install message handlers"
|
||||
remaining-stx))
|
||||
|
||||
(push! gestalt-fragments
|
||||
#`(gestalt-union* (for/list #,loopspecs-stx
|
||||
#,@(if condition
|
||||
#`(#:when #,condition)
|
||||
#'())
|
||||
(#,(if pub? #'pub #'sub) #,gestalt-stx
|
||||
#:meta-level #,(or meta-level 0))))))
|
||||
|
||||
(define (push-action! action-stx)
|
||||
(define-temporaries [temp action-stx])
|
||||
(push! action-ids temp)
|
||||
(push! body-forms #`(define #,temp #,action-stx)))
|
||||
|
||||
(define (build-result)
|
||||
(let ((actor-name (or actor-name #'anonymous-actor)))
|
||||
(define state-struct-name
|
||||
(datum->syntax actor-form-head-stx (string->symbol (format "~a-state" (syntax->datum actor-name)))))
|
||||
(define-temporaries
|
||||
[e-stx #'event]
|
||||
[state-stx #'state]
|
||||
[update-gestalt-stx #'update-gestalt])
|
||||
(define result
|
||||
#`(let ()
|
||||
(struct #,state-struct-name (#,@statevars) #:prefab)
|
||||
(let ()
|
||||
#,@(for/list [(sv statevars)] #`(define-syntax-parameter #,sv #f))
|
||||
(syntax-parameterize
|
||||
((update-state-struct
|
||||
(syntax-rules () [(_ v [n e] (... ...))
|
||||
(struct-copy #,state-struct-name v [n e] (... ...))]))
|
||||
(match-state
|
||||
(syntax-rules () [(_ id body (... ...))
|
||||
(match-lambda
|
||||
[(and id (struct #,state-struct-name (#,@statetemps)))
|
||||
(syntax-parameterize
|
||||
(#,@(for/list ([sv statevars] [si statetemps])
|
||||
#`(#,sv (syntax-id-rules () [_ #,si]))))
|
||||
body (... ...))])])))
|
||||
(splicing-syntax-parameterize
|
||||
((update-gestalt (syntax-id-rules () [_ #,update-gestalt-stx]))
|
||||
#,@(for/list ([sv statevars] [si statetemps])
|
||||
#`(#,sv (syntax-id-rules () [_ #,si]))))
|
||||
#,@(reverse body-forms)
|
||||
(define #,update-gestalt-stx
|
||||
(begin-transition
|
||||
#,@gestalt-updaters
|
||||
(routing-update (gestalt-union #,@gestalt-fragments))))
|
||||
(match (#,update-gestalt-stx (#,state-struct-name #,@statevars))
|
||||
[(transition #,state-stx initial-gestalt-actions)
|
||||
(match-define (list (routing-update initial-gestalt))
|
||||
(clean-actions initial-gestalt-actions))
|
||||
(spawn #:boot (begin-transition #,@(reverse action-ids))
|
||||
(procedure-rename
|
||||
(lambda (#,e-stx #,state-stx)
|
||||
(and #,e-stx
|
||||
(sequence-transitions (transition #,state-stx '())
|
||||
#,@(map (lambda (p) (p e-stx))
|
||||
(reverse event-handlers)))))
|
||||
'#,actor-name)
|
||||
#,state-stx
|
||||
initial-gestalt)]))))))
|
||||
;; (pretty-print `(result ,(syntax->datum result)))
|
||||
result))
|
||||
|
||||
(walk-forms forms-stx))
|
||||
|
||||
(define (expand-in-context context-id stx)
|
||||
(local-expand stx
|
||||
(list context-id)
|
||||
(syntax->list #'(quote quote-syntax lambda case-lambda let-values letrec-values
|
||||
begin begin0 set! with-continuation-mark if #%app #%expression
|
||||
define-values define-syntaxes begin-for-syntax #%require #%provide
|
||||
#%variable-reference))))
|
||||
|
||||
(define (accumulate-actions context-id action-ids final-forms forms)
|
||||
(syntax-case forms ()
|
||||
[()
|
||||
#`(match-state state
|
||||
#,@(reverse final-forms)
|
||||
(transition state (list #,@(reverse action-ids))))]
|
||||
|
||||
[(#:run-transition exp rest ...)
|
||||
#`(match-state state
|
||||
#,@(reverse final-forms)
|
||||
(sequence-transitions (transition state (list #,@(reverse action-ids)))
|
||||
exp
|
||||
(begin-transition rest ...)))]
|
||||
|
||||
[(#:update [statevar stateval] rest ...)
|
||||
#`(match-state state
|
||||
#,@(reverse final-forms)
|
||||
(sequence-transitions (transition (update-state-struct state [statevar stateval])
|
||||
(list #,@(reverse action-ids)))
|
||||
(begin-transition rest ...)))]
|
||||
|
||||
[(#:update-routes rest ...)
|
||||
#`(match-state state
|
||||
#,@(reverse final-forms)
|
||||
(sequence-transitions (transition state (list #,@(reverse action-ids)))
|
||||
update-gestalt
|
||||
(begin-transition rest ...)))]
|
||||
|
||||
[(expr rest ...)
|
||||
(syntax-case (expand-in-context context-id #'expr) ()
|
||||
[(head inner-rest ...)
|
||||
(if (or (free-identifier=? #'head #'begin)
|
||||
(free-identifier=? #'head #'begin-transition))
|
||||
(accumulate-actions context-id
|
||||
action-ids
|
||||
final-forms
|
||||
(append (syntax->list #'(inner-rest ...)) #'(rest ...)))
|
||||
(if (ormap (lambda (i) (free-identifier=? #'head i))
|
||||
(syntax->list #'(define-values define-syntaxes begin-for-syntax
|
||||
module module*
|
||||
#%module-begin
|
||||
#%require #%provide)))
|
||||
(accumulate-actions context-id
|
||||
action-ids
|
||||
(cons #'expr final-forms)
|
||||
#'(rest ...))
|
||||
(accumulate-action #'expr
|
||||
context-id
|
||||
action-ids
|
||||
final-forms
|
||||
#'(rest ...))))]
|
||||
[non-pair-syntax
|
||||
(accumulate-action #'expr
|
||||
context-id
|
||||
action-ids
|
||||
final-forms
|
||||
#'(rest ...))])]))
|
||||
|
||||
(define (accumulate-action action-stx context-id action-ids final-forms remaining-forms)
|
||||
(define-temporaries [temp action-stx])
|
||||
(accumulate-actions context-id
|
||||
(cons temp action-ids)
|
||||
(cons #`(define #,temp #,action-stx) final-forms)
|
||||
remaining-forms)))
|
||||
|
||||
;;; Local Variables:
|
||||
;;; eval: (put 'begin-transition 'scheme-indent-function 0)
|
||||
;;; eval: (put 'observe-gestalt 'scheme-indent-function 1)
|
||||
;;; eval: (put 'observe-subscribers 'scheme-indent-function 1)
|
||||
;;; eval: (put 'observe-advertisers 'scheme-indent-function 1)
|
||||
;;; eval: (put 'subscribe 'scheme-indent-function 1)
|
||||
;;; eval: (put 'advertise 'scheme-indent-function 1)
|
||||
;;; End:
|
||||
|
|
@ -1,105 +0,0 @@
|
|||
#lang racket/base
|
||||
;; Remote VM link.
|
||||
|
||||
(provide spawn-broker-client)
|
||||
|
||||
(require racket/match)
|
||||
(require net/rfc6455)
|
||||
(require "../main.rkt")
|
||||
(require "../route.rkt")
|
||||
(require "../gestalt.rkt")
|
||||
(require "../drivers/timer.rkt")
|
||||
(require "../drivers/websocket.rkt")
|
||||
(require "../deduplicator.rkt")
|
||||
(require json)
|
||||
(require "protocol.rkt")
|
||||
|
||||
(define (collect-matchers label advertisements? level g)
|
||||
(define projector (if advertisements? project-pubs project-subs))
|
||||
(define extract-metalevels (projector (list label (?!) ?) #:level level))
|
||||
(define mls (gestalt-project/single g extract-metalevels))
|
||||
(for/fold [(result (gestalt-empty))] [(metalevel mls)]
|
||||
(define m (gestalt-project g (projector (list label metalevel (?!)))))
|
||||
(gestalt-union result (simple-gestalt advertisements? (embedded-matcher m) level metalevel))))
|
||||
|
||||
(define (lift-matcher-into-labelled-space m label metalevel)
|
||||
(pattern->matcher #t (list label metalevel (embedded-matcher m))))
|
||||
|
||||
(define (lift-gestalt-into-labelled-space g label)
|
||||
(gestalt-transform g (lambda (ml l matchers)
|
||||
(cons (lift-matcher-into-labelled-space (car matchers) label ml)
|
||||
(lift-matcher-into-labelled-space (cdr matchers) label ml)))))
|
||||
|
||||
(define (spawn-broker-client label url)
|
||||
(define client-id (websocket-local-client (list 'broker-client label)))
|
||||
(define server-id (websocket-remote-server url))
|
||||
(actor #:name broker-client
|
||||
#:state [local-gestalt (gestalt-empty)]
|
||||
#:state [peer-gestalt (gestalt-empty)]
|
||||
#:state [deduplicator (make-deduplicator)]
|
||||
#:state [seen-remote? #f]
|
||||
|
||||
(send (set-timer client-id (ping-interval) 'relative))
|
||||
(subscribe (timer-expired client-id ?)
|
||||
(send (set-timer client-id (ping-interval) 'relative))
|
||||
(send-action 'ping))
|
||||
|
||||
(advertise (websocket-message client-id server-id ?))
|
||||
(subscribe (websocket-message server-id client-id ($ data))
|
||||
#:run-transition
|
||||
(match (drop-json-event (string->jsexpr data))
|
||||
[(routing-update new-peer-gestalt)
|
||||
(begin-transition
|
||||
#:run-transition (if (equal? peer-gestalt new-peer-gestalt)
|
||||
(begin-transition)
|
||||
(begin-transition
|
||||
#:update [peer-gestalt new-peer-gestalt]
|
||||
#:update-routes)))]
|
||||
[(? message? m (message body meta-level feedback?))
|
||||
(begin-transition
|
||||
(define-values (fresh? d) (deduplicator-accept deduplicator m))
|
||||
#:update [deduplicator d]
|
||||
(when fresh? (message (list label meta-level body) 0 feedback?)))]
|
||||
['ping
|
||||
(begin-transition (send-action 'pong))]
|
||||
['pong
|
||||
(begin-transition)]))
|
||||
|
||||
(observe-advertisers (websocket-message server-id client-id ?)
|
||||
#:presence peer-connected?
|
||||
(when (and seen-remote? (not peer-connected?)) (quit)) ;; TODO: reconnect
|
||||
#:update [seen-remote? (or seen-remote? peer-connected?)])
|
||||
|
||||
(observe-gestalt
|
||||
(gestalt-union (pub (list label ? ?) #:level 10)
|
||||
(sub (list label ? ?) #:level 10)
|
||||
;; TODO: ^ level 10 is ad-hoc; support
|
||||
;; infinity at some point in future
|
||||
(lift-gestalt-into-labelled-space peer-gestalt label))
|
||||
[(routing-update g)
|
||||
(local-require "../trace.rkt")
|
||||
(define current-pid (car (trace-pid-stack))) ;; EWWWWW
|
||||
;; TODO: gross - erasing by pid!
|
||||
(define level-count (gestalt-level-count g 0))
|
||||
(define to-subtract (label-gestalt (gestalt-full 1 level-count) current-pid))
|
||||
#:run-transition
|
||||
(let ((g (gestalt-subtract g to-subtract)))
|
||||
(define new-local-gestalt
|
||||
(for/fold [(new-local-gestalt (gestalt-empty))] [(level level-count)]
|
||||
(gestalt-union new-local-gestalt
|
||||
(collect-matchers label #f level g)
|
||||
(collect-matchers label #t level g))))
|
||||
(if (equal? local-gestalt new-local-gestalt)
|
||||
(begin-transition)
|
||||
(begin-transition
|
||||
#:update [local-gestalt new-local-gestalt]
|
||||
(send-action (routing-update local-gestalt)))))]
|
||||
[(message (list (== label) meta-level body) 0 feedback?)
|
||||
(define m (message body meta-level feedback?))
|
||||
(define-values (fresh? d) (deduplicator-accept deduplicator m))
|
||||
#:update [deduplicator d]
|
||||
(when fresh? (send-action m))])
|
||||
|
||||
(define (send-action e)
|
||||
(define s (jsexpr->string (lift-json-action e)))
|
||||
(send (websocket-message client-id server-id s)))))
|
||||
|
|
@ -1,40 +0,0 @@
|
|||
#lang racket/base
|
||||
;; Generic protocol for WebSockets/TCP/etc-based participation in a network.
|
||||
|
||||
(provide drop-json-action
|
||||
lift-json-event
|
||||
lift-json-action
|
||||
drop-json-event
|
||||
ping-interval)
|
||||
|
||||
(require net/rfc6455)
|
||||
(require racket/set)
|
||||
(require racket/match)
|
||||
(require "../main.rkt")
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Wire protocol representation of events and actions
|
||||
|
||||
(define (drop j)
|
||||
(match j
|
||||
["ping" 'ping]
|
||||
["pong" 'pong]
|
||||
[`("routes" ,gj) (routing-update (jsexpr->gestalt gj (lambda (v) (set 'peer))))]
|
||||
[`("message" ,body ,meta-level ,feedback?) (message body meta-level feedback?)]))
|
||||
|
||||
(define (lift j)
|
||||
(match j
|
||||
['ping "ping"]
|
||||
['pong "pong"]
|
||||
[(routing-update g) `("routes" ,(gestalt->jsexpr g (lambda (v) #t)))]
|
||||
[(message body meta-level feedback?) `("message" ,body ,meta-level ,feedback?)]))
|
||||
|
||||
(define drop-json-action drop)
|
||||
(define lift-json-event lift)
|
||||
(define lift-json-action lift)
|
||||
(define drop-json-event drop)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Connections
|
||||
|
||||
(define (ping-interval) (* 1000 (max (- (ws-idle-timeout) 10) (* (ws-idle-timeout) 0.8))))
|
||||
|
|
@ -1,65 +0,0 @@
|
|||
#lang racket/base
|
||||
;; Generic relay for WebSockets/TCP/etc-based participation in a network.
|
||||
|
||||
(provide spawn-broker-server)
|
||||
|
||||
(require racket/set)
|
||||
(require racket/match)
|
||||
(require net/rfc6455)
|
||||
(require "../main.rkt")
|
||||
(require "../demand-matcher.rkt")
|
||||
(require "../drivers/timer.rkt")
|
||||
(require "../drivers/websocket.rkt")
|
||||
(require json)
|
||||
(require "protocol.rkt")
|
||||
|
||||
;; Depends on timer driver and websocket driver running at metalevel 1.
|
||||
(define (spawn-broker-server port [ssl-options #f])
|
||||
(define server-id (websocket-local-server port ssl-options))
|
||||
(spawn-demand-matcher (websocket-message (?! (websocket-remote-client ?)) server-id ?)
|
||||
#:meta-level 1
|
||||
(lambda (c) (spawn-connection-handler c server-id))))
|
||||
|
||||
(define (spawn-connection-handler c server-id)
|
||||
(actor #:name broker-server
|
||||
#:state [tunnelled-gestalt (gestalt-empty)]
|
||||
|
||||
(send #:meta-level 1 (set-timer c (ping-interval) 'relative))
|
||||
(subscribe (timer-expired c ?)
|
||||
#:meta-level 1
|
||||
(send #:meta-level 1 (set-timer c (ping-interval) 'relative))
|
||||
(send-event 'ping))
|
||||
|
||||
(observe-advertisers (websocket-message c server-id ?)
|
||||
#:meta-level 1
|
||||
#:presence peer-connected?
|
||||
(when (not peer-connected?) (quit)))
|
||||
|
||||
(advertise (websocket-message server-id c ?) #:meta-level 1)
|
||||
(subscribe (websocket-message c server-id ($ data))
|
||||
#:meta-level 1
|
||||
#:run-transition (handle-incoming (drop-json-action (string->jsexpr data))))
|
||||
|
||||
(define (handle-incoming data)
|
||||
(match data
|
||||
[(routing-update g-unfiltered)
|
||||
(define g (gestalt-transform g-unfiltered
|
||||
(lambda (ml l p) (if (zero? ml) p '(#f . #f)))))
|
||||
(begin-transition
|
||||
#:update [tunnelled-gestalt g]
|
||||
#:update-routes)]
|
||||
[(? message? m)
|
||||
(begin-transition
|
||||
(when (zero? (message-meta-level m)) m))]
|
||||
['ping
|
||||
(begin-transition (send-event 'pong))]
|
||||
['pong
|
||||
(begin-transition)]))
|
||||
|
||||
(observe-gestalt tunnelled-gestalt
|
||||
[event ;; routing-update or message, prefiltered by tunnelled-gestalt
|
||||
(send-event event)])
|
||||
|
||||
(define (send-event e)
|
||||
(send #:meta-level 1
|
||||
(websocket-message server-id c (jsexpr->string (lift-json-event e)))))))
|
||||
|
|
@ -1,47 +0,0 @@
|
|||
#lang racket/base
|
||||
;; Poor-man's hash consing.
|
||||
|
||||
(provide canonicalize)
|
||||
|
||||
(define canonical-values (make-weak-hash))
|
||||
|
||||
(define sentinel (cons #f #f))
|
||||
|
||||
(define (canonicalize val)
|
||||
(define b (hash-ref canonical-values
|
||||
val
|
||||
(lambda ()
|
||||
(define new-b (make-weak-box val))
|
||||
(hash-set! canonical-values val new-b)
|
||||
#f)))
|
||||
(if (not b)
|
||||
(canonicalize val)
|
||||
(let ((v (weak-box-value b sentinel)))
|
||||
(if (eq? v sentinel) (canonicalize val) v))))
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
|
||||
(define v1 (canonicalize (cons 1 2)))
|
||||
|
||||
(let ((v2 (canonicalize (cons 1 2))))
|
||||
(check-eq? v1 v2))
|
||||
|
||||
(collect-garbage)
|
||||
(check-equal? (hash-count canonical-values) 1)
|
||||
|
||||
(let ((v2 (canonicalize (cons 1 2))))
|
||||
(check-eq? v1 v2))
|
||||
|
||||
(set! v1 (canonicalize (cons 1 2)))
|
||||
|
||||
(collect-garbage)
|
||||
(check-equal? (hash-count canonical-values) 1)
|
||||
|
||||
(let ((v2 (canonicalize (cons 1 2))))
|
||||
(check-eq? v1 v2))
|
||||
|
||||
(set! v1 #f)
|
||||
|
||||
(collect-garbage)
|
||||
(check-equal? (hash-count canonical-values) 0))
|
||||
|
|
@ -1,523 +1,314 @@
|
|||
#lang racket/base
|
||||
;; Core implementation of network actors and Network Calculus (NC) communication API.
|
||||
|
||||
(require racket/set)
|
||||
(require racket/match)
|
||||
(require racket/list)
|
||||
(require "route.rkt")
|
||||
(require "gestalt.rkt")
|
||||
(require "pattern.rkt")
|
||||
(require "functional-queue.rkt")
|
||||
(require "trace.rkt")
|
||||
(require "tset.rkt")
|
||||
(require (only-in web-server/private/util exn->string))
|
||||
|
||||
(provide (struct-out routing-update)
|
||||
(provide (struct-out route)
|
||||
(struct-out routing-update)
|
||||
(struct-out message)
|
||||
(struct-out quit)
|
||||
(except-out (struct-out spawn) spawn)
|
||||
(rename-out [make-spawn spawn] [spawn <spawn>])
|
||||
(struct-out process)
|
||||
(struct-out transition)
|
||||
|
||||
(struct-out trigger-guard)
|
||||
|
||||
(except-out (struct-out world) world)
|
||||
|
||||
;; imported from route.rkt:
|
||||
?
|
||||
? ;; imported from pattern.rkt
|
||||
wildcard?
|
||||
?!
|
||||
(struct-out capture)
|
||||
pretty-print-matcher
|
||||
matcher->pretty-string
|
||||
matcher-empty?
|
||||
(rename-out [projection->pattern matcher-projection->pattern]
|
||||
[compile-projection compile-matcher-projection])
|
||||
|
||||
sub
|
||||
pub
|
||||
gestalt-accepts?
|
||||
filter-event
|
||||
|
||||
gestalt-ref
|
||||
gestalt-empty
|
||||
gestalt-empty?
|
||||
gestalt-union
|
||||
gestalt-filter
|
||||
pretty-print-matcher
|
||||
pretty-print-gestalt
|
||||
spawn
|
||||
send
|
||||
feedback
|
||||
co-route
|
||||
route-accepts?
|
||||
intersect-routes
|
||||
spawn-world
|
||||
deliver-event
|
||||
transition-bind
|
||||
sequence-transitions
|
||||
clean-actions
|
||||
routing-implementation)
|
||||
routing-implementation
|
||||
|
||||
;; A PID is a number uniquely identifying a Process within a World.
|
||||
;; Note that PIDs are only meaningful within the context of their
|
||||
;; World: they are not global Process identifiers.
|
||||
log-events-and-actions?)
|
||||
|
||||
;; TODO: support +Inf.0 as a level number
|
||||
(define pid-stack (make-parameter '()))
|
||||
(define log-events-and-actions? (make-parameter #f))
|
||||
|
||||
;; An Event is a communication from a World to a Process contained
|
||||
;; within it. One of
|
||||
;; - (routing-update Gestalt), description of change in the sender's interests/subscriptions
|
||||
;; - (message Any Nat Boolean), a (multicast, in general) message sent by an actor
|
||||
;; A message's (feedback?) field is #f when it is a message
|
||||
;; originating from an advertiser/publisher and terminating with a
|
||||
;; subscriber, and #t in the opposite case.
|
||||
(struct routing-update (gestalt) #:prefab)
|
||||
(struct route (subscription? pattern meta-level level) #:prefab)
|
||||
|
||||
;; Events
|
||||
(struct routing-update (routes) #:prefab)
|
||||
(struct message (body meta-level feedback?) #:prefab)
|
||||
|
||||
;; An Action is a communication from a Process to its containing
|
||||
;; World, instructing the World to take some action on the Process's
|
||||
;; behalf. One of
|
||||
;; - an Event: change in the Process's interests, or message from the Process
|
||||
;; - (spawn (Constreeof Action) Process): instruction to spawn a new process as described
|
||||
;; - (quit): instruction to terminate the sending process
|
||||
;; Actions (in addition to Events)
|
||||
;; (spawn is just process)
|
||||
(struct quit () #:prefab)
|
||||
(struct spawn (boot-proc process) #:prefab)
|
||||
|
||||
;; A PendingEvent is a description of a set of Events to be
|
||||
;; communicated to a World's Processes. In naïve implementations of
|
||||
;; NC, there is no distinction between Events and PendingEvents; here,
|
||||
;; we must ensure that the buffering delay doesn't affect the Gestalts
|
||||
;; communicated in routing-update Events, so a special record is used
|
||||
;; to capture the appropriate Gestalt environment.
|
||||
;; - (pending-routing-update Gestalt Gestalt (Option PID))
|
||||
(struct pending-routing-update (aggregate affected-subgestalt known-target) #:prefab)
|
||||
;; Actors and Configurations
|
||||
(struct process (routes behavior state) #:transparent)
|
||||
(struct world (next-pid event-queue process-table downward-routes process-actions) #:transparent)
|
||||
|
||||
;; A Process (a.k.a. Actor) describes a single actor in a World.
|
||||
;; - (process Gestalt Behavior Any)
|
||||
;; The Gestalt describes the current interests of the Process: either
|
||||
;; those it was spawned with, or the most recent interests from a
|
||||
;; routing-update Action.
|
||||
(struct process (gestalt behavior state) #:transparent)
|
||||
|
||||
;; A World (a.k.a Configuration) is the state of an actor representing
|
||||
;; a group of communicating Processes. The term is also used from time
|
||||
;; to time to denote the actor having a World as its state and
|
||||
;; world-handle-event as its Behavior.
|
||||
(struct world (next-pid ;; PID, for next-spawned process
|
||||
pending-event-queue ;; (Queueof PendingEvent)
|
||||
runnable-pids ;; (Setof PID), non-inert processes
|
||||
partial-gestalt ;; Gestalt, from local processes only; maps to PID
|
||||
full-gestalt ;; Gestalt, union of partial- and downward-gestalts
|
||||
process-table ;; (HashTable PID Process)
|
||||
downward-gestalt ;; Gestalt, representing interests of outside world
|
||||
process-actions ;; (Queueof (Pairof PID Action))
|
||||
) #:transparent)
|
||||
|
||||
;; A Behavior is a ((Option Event) Any -> Transition): a function
|
||||
;; mapping an Event (or, in the #f case, a poll signal) and a
|
||||
;; Process's current state to a Transition.
|
||||
;;
|
||||
;; A Transition is either
|
||||
;; - #f, a signal from a Process that it is inert and need not be
|
||||
;; scheduled until some Event relevant to it arrives; or,
|
||||
;; - a (transition Any (Constreeof Action)), a new Process state to
|
||||
;; be held by its World and a sequence of Actions for the World
|
||||
;; to take on the transitioning Process's behalf.
|
||||
;; Behavior : maybe event * state -> transition
|
||||
(struct transition (state actions) #:transparent)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Protocol and utilities
|
||||
;; Process table maps to these; idea is to avoid redundant signalling
|
||||
;; of routing-updates where possible
|
||||
(struct trigger-guard (process downward-routes) #:transparent)
|
||||
|
||||
;; sub : Pattern [#:meta-level Nat] [#:level Nat] -> Gestalt
|
||||
;; pub : Pattern [#:meta-level Nat] [#:level Nat] -> Gestalt
|
||||
;;
|
||||
;; Construct atomic Gestalts representing subscriptions/advertisements
|
||||
;; matching the given pattern, at the given meta-level and level.
|
||||
;; These are frequently used in combination with gestalt-union when
|
||||
;; building spawn and routing-update Actions.
|
||||
(define (sub p #:meta-level [ml 0] #:level [l 0]) (simple-gestalt #f p l ml))
|
||||
(define (pub p #:meta-level [ml 0] #:level [l 0]) (simple-gestalt #t p l ml))
|
||||
(define (drop-route r)
|
||||
(match-define (route s? p ml l) r)
|
||||
(and (positive? ml) (route s? p (- ml 1) l)))
|
||||
|
||||
;; Gestalt Any -> Boolean
|
||||
;; True iff m falls within the set of messages represented by the Gestalt.
|
||||
(define (gestalt-accepts? g m)
|
||||
(match-define (message b ml f?) m)
|
||||
(not (set-empty? (gestalt-match-value g b ml f?))))
|
||||
(define (lift-route r)
|
||||
(match-define (route s? p ml l) r)
|
||||
(route s? p (+ ml 1) l))
|
||||
|
||||
;; (Option Event) Gestalt -> (Option Event)
|
||||
;; Returns a filtered version of e, narrowed to the perspective of g-filter.
|
||||
(define (filter-event e g-filter)
|
||||
(match e
|
||||
[#f #f]
|
||||
[(routing-update g) (routing-update (gestalt-filter g g-filter))]
|
||||
[(? message? m) (and (gestalt-accepts? g-filter m) m)]))
|
||||
(define (sub p #:meta-level [ml 0] #:level [l 0]) (route #t p ml l))
|
||||
(define (pub p #:meta-level [ml 0] #:level [l 0]) (route #f p ml l))
|
||||
|
||||
;; Behavior Any [Gestalt] -> Action
|
||||
;; Constructs a spawn Action for a new process with the given behavior
|
||||
;; and state. If a Gestalt is supplied, the new process will begin its
|
||||
;; existence with the corresponding subscriptions/advertisements/
|
||||
;; conversational-responsibilities.
|
||||
(define (make-spawn #:boot [boot-proc (lambda (state) (transition state '()))]
|
||||
behavior
|
||||
state
|
||||
[gestalt (gestalt-empty)])
|
||||
(spawn boot-proc
|
||||
(process gestalt behavior state)))
|
||||
(define (gestalt-ref g metalevel level get-advertisements?)
|
||||
(filter-map (lambda (r)
|
||||
(match-define (route is-sub? p ml l) r)
|
||||
(and (= ml metalevel)
|
||||
(= l level)
|
||||
(eq? get-advertisements? (not is-sub?))
|
||||
p))
|
||||
(flatten g)))
|
||||
|
||||
;; send : Any [#:meta-level Nat] -> Action
|
||||
;; feedback : Any [#:meta-level Nat] -> Action
|
||||
;;
|
||||
;; Each constructs an Action that will deliver a body to peers at the
|
||||
;; given meta-level. (send) constructs messages that will be delivered
|
||||
;; to subscribers; (feedback), to advertisers.
|
||||
(define (gestalt-union . gs) (flatten gs))
|
||||
(define (gestalt-filter g1 g2) (intersect-routes (flatten g1) (flatten g2)))
|
||||
(define (gestalt-empty) '())
|
||||
(define (gestalt-empty? g) (null? g))
|
||||
|
||||
(require racket/pretty)
|
||||
(define (pretty-print-matcher x #:indent [ignored-indent 0]) (pretty-print x))
|
||||
(define (pretty-print-gestalt x) (pretty-print x))
|
||||
|
||||
(define (spawn behavior state [initial-routes '()]) (process initial-routes behavior state))
|
||||
(define (send body #:meta-level [ml 0]) (message body ml #f))
|
||||
(define (feedback body #:meta-level [ml 0]) (message body ml #t))
|
||||
|
||||
;; Action* -> Action
|
||||
;; Constructs an action which causes the creation of a new World
|
||||
;; Process. The given actions will be taken by a primordial process
|
||||
;; running in the context of the new World.
|
||||
(define (spawn-world . boot-actions)
|
||||
(make-spawn world-handle-event
|
||||
(enqueue-actions (world 0
|
||||
(make-queue)
|
||||
(set)
|
||||
(gestalt-empty)
|
||||
(gestalt-empty)
|
||||
(hash)
|
||||
(gestalt-empty)
|
||||
(make-queue))
|
||||
-1
|
||||
(clean-actions boot-actions))))
|
||||
(define (drop-routes rs) (filter-map drop-route rs))
|
||||
(define (lift-routes rs) (map lift-route rs))
|
||||
|
||||
;; Any -> Boolean; type predicates for Event and Action respectively.
|
||||
(define (event? x) (or (routing-update? x) (message? x)))
|
||||
(define (action? x) (or (event? x) (spawn? x) (quit? x)))
|
||||
(define (co-route r #:level [level-override #f])
|
||||
(match-define (route sub? pat ml l) r)
|
||||
(route (not sub?) pat ml (or level-override l)))
|
||||
|
||||
;; (Any -> Transition) Transition -> Transition
|
||||
;; A kind of monad-ish bind operator: threads the state in t0 through
|
||||
;; k, appending the action sequence from t0 with that from the result
|
||||
;; of calling k.
|
||||
;; TODO: sort out exactly how #f should propagate here
|
||||
(define (transition-bind k t0)
|
||||
(match-define (transition state0 actions0) t0)
|
||||
(match (k state0)
|
||||
[#f t0]
|
||||
[(transition state1 actions1) (transition state1 (cons actions0 actions1))]))
|
||||
(define (route-accepts? r m)
|
||||
(and (= (message-meta-level m) (route-meta-level r))
|
||||
(equal? (message-feedback? m) (not (route-subscription? r)))
|
||||
(intersect? (message-body m) (route-pattern r))))
|
||||
|
||||
;; Transition (Any -> Transition)* -> Transition
|
||||
;; Each step is a function from state to Transition. The state in t0
|
||||
;; is threaded through the steps; the action sequences are appended.
|
||||
(define (sequence-transitions t0 . steps)
|
||||
(foldl transition-bind t0 steps))
|
||||
(define (intersect-routes rs1 rs2)
|
||||
(let loop1 ((rs1 rs1)
|
||||
(acc '()))
|
||||
(match rs1
|
||||
['() (reverse acc)]
|
||||
[(cons r1 rs1)
|
||||
(let loop2 ((rs2 rs2)
|
||||
(acc acc))
|
||||
(match rs2
|
||||
['() (loop1 rs1 acc)]
|
||||
[(cons r2 rs2)
|
||||
(if (and (equal? (route-subscription? r1) (not (route-subscription? r2)))
|
||||
(= (route-meta-level r1) (route-meta-level r2))
|
||||
(< (route-level r1) (route-level r2)))
|
||||
(intersect (route-pattern r1) (route-pattern r2)
|
||||
(lambda (rr) (loop2 rs2 (cons (struct-copy route r1 [pattern rr]) acc)))
|
||||
(lambda () (loop2 rs2 acc)))
|
||||
(loop2 rs2 acc))]))])))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Trigger guards
|
||||
|
||||
;; TriggerGuards wrap process Behavior and state, only passing through
|
||||
;; routing-update Events to their contained process behavior/state if
|
||||
;; there has been a change. All other Events go straight through.
|
||||
;;
|
||||
;; - (trigger-guard Gestalt Behavior Any)
|
||||
;;
|
||||
;; The structural similarity to Processes is meaningful: a Process
|
||||
;; describes the current interests of the Process, as well as its
|
||||
;; behavior. A TriggerGuard describes the current interests of the
|
||||
;; Process's *environment*, and doesn't bother passing on a
|
||||
;; routing-update unless the change is non-zero.
|
||||
(struct trigger-guard (gestalt handler state) #:transparent)
|
||||
|
||||
;; Behavior :> (Option Event) TriggerGuard -> Transition
|
||||
;; Inspects the given event: if it is a routing update, the contained
|
||||
;; Gestalt is compared to the TriggerGuard's record of the previous
|
||||
;; Gestalt from the environment, and only if it is different is it
|
||||
;; passed on.
|
||||
(define (trigger-guard-handle e s0)
|
||||
(match-define (trigger-guard old-gestalt handler old-state) s0)
|
||||
(define (deliver s)
|
||||
(match (ensure-transition (handler e old-state))
|
||||
[#f
|
||||
(if (eq? s s0) #f (transition s '()))]
|
||||
[(transition new-state actions)
|
||||
(transition (struct-copy trigger-guard s [state new-state]) actions)]))
|
||||
(define (filter-event e rs)
|
||||
(match e
|
||||
[(routing-update new-gestalt)
|
||||
(if (equal? new-gestalt old-gestalt)
|
||||
#f
|
||||
(deliver (struct-copy trigger-guard s0 [gestalt new-gestalt])))]
|
||||
[_ (deliver s0)]))
|
||||
[(routing-update e-rs)
|
||||
(routing-update (intersect-routes e-rs rs))]
|
||||
[(? message? m)
|
||||
(if (ormap (lambda (r) (route-accepts? r m)) rs) e #f)]))
|
||||
|
||||
;; Process -> Process
|
||||
;; Wraps a Process in a TriggerGuard.
|
||||
(define (trigger-guard-process p)
|
||||
(match-define (process _ b s) p)
|
||||
(struct-copy process p [behavior trigger-guard-handle] [state (trigger-guard #f b s)]))
|
||||
(define (spawn-world . boot-actions)
|
||||
(spawn world-handle-event
|
||||
(enqueue-actions (world 0 (make-queue) (hash) '() (make-queue))
|
||||
-1
|
||||
boot-actions)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; World implementation
|
||||
(define (event? x) (or (routing-update? x) (message? x)))
|
||||
(define (action? x) (or (event? x) (process? x) (quit? x)))
|
||||
|
||||
;; Each time a world is handed an event from its environment, it:
|
||||
;; 1. dispatches PendingEvents
|
||||
;; a. removing them one-at-a-time from the queue
|
||||
;; b. converting them to Events and dispatching them to processes
|
||||
;; c. updating process states and accumulating Actions in the queue
|
||||
;; d. any process that returned non-#f is considered "non-idle" for step 3.
|
||||
;; 2. performs Actions
|
||||
;; a. removing them one-at-a-time from the queue
|
||||
;; b. interpreting them
|
||||
;; c. updating World state and accumulating PendingEvents in the queue
|
||||
;; 3. steps non-idle processes
|
||||
;; a. runs through the runnable-pids set of processes accumulated in 1d. above
|
||||
;; b. any process that returned non-#f is put in the "non-idle" set for next time
|
||||
;; 4. yields updated World state and world Actions to the environment.
|
||||
;;
|
||||
;; Note that routing-update Actions are queued as
|
||||
;; pending-routing-update structures in order to preserve and
|
||||
;; communicate transient Gestalt states to Processes. In addition, the
|
||||
;; known-target field of a pending-routing-update structure is used to
|
||||
;; provide NC's initial Gestalt signal to a newly-spawned process.
|
||||
;;
|
||||
;; TODO: should step 3 occur before step 1?
|
||||
|
||||
;; World PID (Listof Action) -> World
|
||||
;; Stores actions taken by PID for later interpretation.
|
||||
(define (enqueue-actions w pid actions)
|
||||
(struct-copy world w
|
||||
[process-actions (queue-append-list (world-process-actions w)
|
||||
(for/list [(a actions)] (cons pid a)))]))
|
||||
(filter-map (lambda (a) (and (action? a) (cons pid a)))
|
||||
(flatten actions)))]))
|
||||
|
||||
;; World -> Boolean
|
||||
;; True if the World has no further reductions it can take.
|
||||
;;
|
||||
;; The code is written to maintain the runnable-pids set carefully, to
|
||||
;; ensure we can locally decide whether we're inert or not without
|
||||
;; having to search the whole deep process tree.
|
||||
(define (inert? w)
|
||||
(and (queue-empty? (world-pending-event-queue w))
|
||||
(queue-empty? (world-process-actions w))
|
||||
(set-empty? (world-runnable-pids w))))
|
||||
(define (quiescent? w)
|
||||
(and (queue-empty? (world-event-queue w))
|
||||
(queue-empty? (world-process-actions w))))
|
||||
|
||||
;; Event PID Process World -> World
|
||||
;; Delivers the event to the process, then applies the resulting
|
||||
;; transition, updating the world.
|
||||
(define (step-process e pid p w)
|
||||
(apply-transition pid (deliver-event e pid p) w))
|
||||
|
||||
;; Event PID Process -> Transition
|
||||
;; Delivers the event to the process.
|
||||
(define (deliver-event e pid p)
|
||||
(invoke-process (process-behavior p) e pid p))
|
||||
(parameterize ((pid-stack (cons pid (pid-stack))))
|
||||
(when (and (log-events-and-actions?) e)
|
||||
(log-info "~a: ~v --> ~v ~v"
|
||||
(reverse (pid-stack))
|
||||
e
|
||||
(process-behavior p)
|
||||
(if (world? (process-state p))
|
||||
"#<world>"
|
||||
(process-state p))))
|
||||
(with-handlers ([(lambda (exn) #t)
|
||||
(lambda (exn)
|
||||
(log-error "Process ~a died with exception:\n~a" pid (exn->string exn))
|
||||
(transition (process-state p) (list (quit))))])
|
||||
(match (with-continuation-mark 'minimart-process
|
||||
pid ;; TODO: debug-name, other user annotation
|
||||
((process-behavior p) e (process-state p)))
|
||||
[#f #f]
|
||||
[(? transition? t) t]
|
||||
[x
|
||||
(log-error "Process ~a returned non-#f, non-transition: ~v" pid x)
|
||||
(transition (process-state p) (list (quit)))]))))
|
||||
|
||||
;; (Any -> (Option Transition)) PID Process -> (Option Transition)
|
||||
;; Calls f in the context of the given process, catching exceptions.
|
||||
(define (invoke-process f e pid p)
|
||||
(define-values (maybe-exn t)
|
||||
(call-in-trace-context
|
||||
pid
|
||||
(lambda ()
|
||||
(with-handlers ([(lambda (exn) #t)
|
||||
(lambda (exn) (values exn (transition (process-state p) (list (quit)))))])
|
||||
(values
|
||||
#f
|
||||
(clean-transition
|
||||
(ensure-transition (with-continuation-mark 'minimart-process pid (f e (process-state p))))))))))
|
||||
(trace-process-step e pid p maybe-exn t)
|
||||
t)
|
||||
|
||||
;; Any -> (Option Transition)
|
||||
;; If its argument is non-#f, non-transition, raises an exception.
|
||||
(define (ensure-transition v)
|
||||
(if (or (not v) (transition? v))
|
||||
v
|
||||
(raise (exn:fail:contract (format "Expected transition (or #f); got ~v" v)
|
||||
(current-continuation-marks)))))
|
||||
|
||||
;; (Option Transition) -> (Option Transition)
|
||||
;; Filters and flattens action constree in argument.
|
||||
(define (clean-transition t)
|
||||
(and t (transition (transition-state t) (clean-actions (transition-actions t)))))
|
||||
|
||||
;; (Constreeof Any) -> (Listof Action)
|
||||
;; Filters and flattens its argument to a list of actions.
|
||||
(define (clean-actions actions)
|
||||
(filter action? (flatten actions)))
|
||||
|
||||
;; World PID -> World
|
||||
;; Marks the given PID as not-provably-inert.
|
||||
(define (mark-pid-runnable w pid)
|
||||
(struct-copy world w [runnable-pids (set-add (world-runnable-pids w) pid)]))
|
||||
|
||||
;; PID Transition World -> World
|
||||
;; Examines the given Transition, updating PID's Process's state and
|
||||
;; enqueueing Actions for later interpretation. When the Transition is
|
||||
;; non-#f, PID's Process may wish to take further internal reductions,
|
||||
;; so we mark it as runnable.
|
||||
(define (apply-transition pid t w)
|
||||
(match t
|
||||
[#f w]
|
||||
[(transition new-state new-actions)
|
||||
(let* ((w (transform-process pid w (lambda (p) (struct-copy process p [state new-state])))))
|
||||
(enqueue-actions (mark-pid-runnable w pid) pid new-actions))]))
|
||||
(let* ((w (transform-process pid w
|
||||
(lambda (p)
|
||||
(when (and (log-events-and-actions?)
|
||||
(not (null? (flatten new-actions))))
|
||||
(log-info "~a: ~v <-- ~v ~v"
|
||||
(reverse (cons pid (pid-stack)))
|
||||
new-actions
|
||||
(process-behavior p)
|
||||
(if (world? new-state)
|
||||
"#<world>"
|
||||
new-state)))
|
||||
(struct-copy process p [state new-state]))
|
||||
values)))
|
||||
(enqueue-actions w pid new-actions))]))
|
||||
|
||||
;; PendingEvent World -> World
|
||||
;; Enqueue a PendingEvent for later interpretation and dispatch.
|
||||
(define (enqueue-pending-event e w)
|
||||
(struct-copy world w [pending-event-queue (enqueue (world-pending-event-queue w) e)]))
|
||||
(define (step-children w)
|
||||
(let-values (((w step-taken?)
|
||||
(for/fold ([w w] [step-taken? #f]) (((pid g) (in-hash (world-process-table w))))
|
||||
(match-define (trigger-guard p _) g)
|
||||
(define t (deliver-event #f pid p))
|
||||
(values (apply-transition pid t w)
|
||||
(or step-taken? (transition? t))))))
|
||||
(and step-taken? (transition w '()))))
|
||||
|
||||
(define (transition-bind k t0)
|
||||
(match-define (transition state0 actions0) t0)
|
||||
(match-define (transition state1 actions1) (k state0))
|
||||
(transition state1 (cons actions0 actions1)))
|
||||
|
||||
(define (sequence-transitions t0 . steps)
|
||||
(foldl transition-bind t0 steps))
|
||||
|
||||
;; World -> Transition
|
||||
;; Examines all queued actions, interpreting them, updating World
|
||||
;; state, and possibly causing the World to send Actions for
|
||||
;; interpretation to its own containing World in turn.
|
||||
(define (perform-actions w)
|
||||
(for/fold ([t (transition (struct-copy world w [process-actions (make-queue)]) '())])
|
||||
((entry (in-list (queue->list (world-process-actions w)))))
|
||||
(match-define (cons pid a) entry)
|
||||
(define t1 (transition-bind (perform-action pid a) t))
|
||||
(trace-internal-step pid a (transition-state t) t1)
|
||||
t1))
|
||||
(transition-bind (perform-action pid a) t)))
|
||||
|
||||
;; World -> Transition
|
||||
;; Interprets queued PendingEvents, delivering resulting Events to Processes.
|
||||
(define (dispatch-pending-events w)
|
||||
(transition (for/fold ([w (struct-copy world w [pending-event-queue (make-queue)])])
|
||||
((e (in-list (queue->list (world-pending-event-queue w)))))
|
||||
(dispatch-pending-event e w))
|
||||
(define (dispatch-events w)
|
||||
(transition (for/fold ([w (struct-copy world w [event-queue (make-queue)])])
|
||||
((e (in-list (queue->list (world-event-queue w)))))
|
||||
(dispatch-event e w))
|
||||
'()))
|
||||
|
||||
;; PID World (Process -> Process) -> World
|
||||
;; Extracts a Process by PID, maps fp over it, and stores the result back into the table.
|
||||
(define (transform-process pid w fp)
|
||||
(define pt (world-process-table w))
|
||||
(match (hash-ref pt pid)
|
||||
(define (transform-process pid w fp frs)
|
||||
(match (hash-ref (world-process-table w) pid)
|
||||
[#f w]
|
||||
[p (struct-copy world w [process-table (hash-set pt pid (fp p))])]))
|
||||
[(trigger-guard p downward-rs)
|
||||
(struct-copy world w
|
||||
[process-table (hash-set (world-process-table w)
|
||||
pid
|
||||
(trigger-guard (fp p) (frs downward-rs)))])]))
|
||||
|
||||
;; World -> World
|
||||
;; Updates the World's cached copy of the union of its partial- and downward-gestalts.
|
||||
(define (update-full-gestalt w)
|
||||
(define new-full-gestalt (gestalt-union (world-partial-gestalt w) (world-downward-gestalt w)))
|
||||
(struct-copy world w [full-gestalt new-full-gestalt]))
|
||||
(define (enqueue-event e w)
|
||||
(struct-copy world w [event-queue (enqueue (world-event-queue w) e)]))
|
||||
|
||||
;; World Gestalt (Option PID) -> World
|
||||
;; Constructs and enqueues a PendingEvent describing a change to the
|
||||
;; World's gestalt falling within the relevant-gestalt *subset* of it.
|
||||
(define (issue-local-routing-update w relevant-gestalt known-target)
|
||||
(enqueue-pending-event (pending-routing-update (world-full-gestalt w)
|
||||
relevant-gestalt
|
||||
known-target)
|
||||
w))
|
||||
(define (upward-routes-change-ignorable? pid w rs)
|
||||
(match (hash-ref (world-process-table w) pid)
|
||||
[#f #t]
|
||||
[(trigger-guard p _) (equal? (process-routes p) rs)]))
|
||||
|
||||
;; World Gestalt (Option PID) -> Transition
|
||||
;; Communicates a change in World's gestalt falling within the
|
||||
;; relevant-gestalt *subset* of it both to local Processes and to the
|
||||
;; World's own containing World.
|
||||
(define (issue-routing-update w relevant-gestalt known-target)
|
||||
(transition (issue-local-routing-update w relevant-gestalt known-target)
|
||||
(routing-update (drop-gestalt (world-partial-gestalt w)))))
|
||||
|
||||
;; World Gestalt Gestalt (Option PID) -> Transition
|
||||
;; Communicates a change in the World gestalt corresponding to a
|
||||
;; change in a single Process's gestalt. The old-gestalt is what the
|
||||
;; Process used to be interested in; new-gestalt is its new interests.
|
||||
(define (apply-and-issue-routing-update w old-gestalt new-gestalt known-target)
|
||||
(define new-partial
|
||||
(gestalt-union (gestalt-subtract (world-partial-gestalt w) old-gestalt) new-gestalt))
|
||||
(issue-routing-update (update-full-gestalt (struct-copy world w [partial-gestalt new-partial]))
|
||||
(gestalt-union old-gestalt new-gestalt)
|
||||
known-target))
|
||||
|
||||
;; PID Action -> World -> Transition
|
||||
;; Interprets a single Action performed by PID, updating World state
|
||||
;; and possibly causing the World to take externally-visible Actions
|
||||
;; as a result.
|
||||
(define ((perform-action pid a) w)
|
||||
(match a
|
||||
[(spawn boot-proc new-p)
|
||||
[(? process? new-p)
|
||||
(let* ((new-pid (world-next-pid w))
|
||||
(initial-t (invoke-process (lambda (e s) (boot-proc s)) '#:boot new-pid new-p))
|
||||
(initial-actions (if initial-t (transition-actions initial-t) '()))
|
||||
(new-p (if initial-t (struct-copy process new-p [state (transition-state initial-t)]) new-p))
|
||||
(new-p (trigger-guard-process new-p))
|
||||
(new-gestalt (label-gestalt (process-gestalt new-p) new-pid))
|
||||
(new-p (struct-copy process new-p [gestalt new-gestalt]))
|
||||
(w (struct-copy world w
|
||||
[next-pid (+ new-pid 1)]
|
||||
[process-table (hash-set (world-process-table w) new-pid new-p)]))
|
||||
(w (enqueue-actions w new-pid initial-actions)))
|
||||
(apply-and-issue-routing-update w (gestalt-empty) new-gestalt new-pid))]
|
||||
(new-p (struct-copy process new-p [routes (flatten (process-routes new-p))]))
|
||||
(w (struct-copy world w [next-pid (+ new-pid 1)]))
|
||||
(w (struct-copy world w [process-table
|
||||
(hash-set (world-process-table w)
|
||||
new-pid
|
||||
(trigger-guard new-p '()))])))
|
||||
(log-info "Spawned process ~a ~v ~v" new-pid (process-behavior new-p) (process-state new-p))
|
||||
(issue-routing-update w))]
|
||||
[(quit)
|
||||
(define pt (world-process-table w))
|
||||
(define p (hash-ref pt pid (lambda () #f)))
|
||||
(if p
|
||||
(let* ((w (struct-copy world w [process-table (hash-remove pt pid)])))
|
||||
(apply-and-issue-routing-update w (process-gestalt p) (gestalt-empty) #f))
|
||||
(transition w '()))]
|
||||
[(routing-update gestalt)
|
||||
(define pt (world-process-table w))
|
||||
(define p (hash-ref pt pid (lambda () #f)))
|
||||
(if p
|
||||
(let* ((old-gestalt (process-gestalt p))
|
||||
(new-gestalt (label-gestalt gestalt pid))
|
||||
(new-p (struct-copy process p [gestalt new-gestalt]))
|
||||
(w (struct-copy world w [process-table (hash-set pt pid new-p)])))
|
||||
(apply-and-issue-routing-update w old-gestalt new-gestalt #f))
|
||||
(transition w '()))]
|
||||
(when (hash-has-key? (world-process-table w) pid) (log-info "Process ~a terminating" pid))
|
||||
(let* ((w (struct-copy world w [process-table (hash-remove (world-process-table w) pid)])))
|
||||
(issue-routing-update w))]
|
||||
[(routing-update routes0)
|
||||
(define routes (flatten routes0))
|
||||
(if (upward-routes-change-ignorable? pid w routes)
|
||||
(transition w '())
|
||||
(let* ((w (transform-process pid w
|
||||
(lambda (p) (struct-copy process p [routes routes]))
|
||||
values)))
|
||||
(issue-routing-update w)))]
|
||||
[(message body meta-level feedback?)
|
||||
(if (zero? meta-level)
|
||||
(transition (enqueue-pending-event a w) '())
|
||||
(transition (enqueue-event a w) '())
|
||||
(transition w (message body (- meta-level 1) feedback?)))]))
|
||||
|
||||
;; PendingEvent World -> World
|
||||
;; Interprets a PendingEvent, delivering the resulting Event(s) to Processes.
|
||||
(define (dispatch-pending-event e w)
|
||||
(match e
|
||||
[(message body meta-level feedback?)
|
||||
(define pids (gestalt-match-value (world-partial-gestalt w) body meta-level feedback?))
|
||||
(define pt (world-process-table w))
|
||||
(for/fold ([w w]) [(pid (in-list (tset->list pids)))] (step-process e pid (hash-ref pt pid) w))]
|
||||
[(pending-routing-update g affected-subgestalt known-target)
|
||||
(define affected-pids (gestalt-match affected-subgestalt g))
|
||||
(define pt (world-process-table w))
|
||||
(for/fold ([w w])
|
||||
[(pid (in-list (tset->list (if known-target (tset-add affected-pids known-target) affected-pids))))]
|
||||
(match (hash-ref pt pid (lambda () #f))
|
||||
[#f w]
|
||||
[p (step-process (routing-update (gestalt-filter g (process-gestalt p))) pid p w)]))]))
|
||||
(define (aggregate-routes base w)
|
||||
(apply append
|
||||
base
|
||||
(for/list ((g (in-hash-values (world-process-table w))))
|
||||
(process-routes (trigger-guard-process g)))))
|
||||
|
||||
;; World -> Transition
|
||||
;; Polls the non-provably-inert processes identified by the
|
||||
;; runnable-pids set (by sending them #f instead of an Event).
|
||||
;;
|
||||
;; N.B.: We also effectively compute whether this entire World is
|
||||
;; inert here.
|
||||
;;
|
||||
;; This is roughly the "schedule" rule of the Network Calculus.
|
||||
(define (step-children w)
|
||||
(define runnable-pids (world-runnable-pids w))
|
||||
(if (set-empty? runnable-pids)
|
||||
#f ;; world is inert.
|
||||
(transition (for/fold ([w (struct-copy world w [runnable-pids (set)])])
|
||||
[(pid (in-set runnable-pids))]
|
||||
(define p (hash-ref (world-process-table w) pid (lambda () #f)))
|
||||
(if (not p) w (step-process #f pid p w)))
|
||||
'()))) ;; world needs another check to see if more can happen.
|
||||
(define (issue-local-routing-update w)
|
||||
(enqueue-event (routing-update (aggregate-routes (world-downward-routes w) w)) w))
|
||||
|
||||
(define (issue-routing-update w)
|
||||
(transition (issue-local-routing-update w)
|
||||
(routing-update (drop-routes (aggregate-routes '() w)))))
|
||||
|
||||
(define (dispatch-event e w)
|
||||
(for/fold ([w w]) (((pid g) (in-hash (world-process-table w))))
|
||||
(match-define (trigger-guard p old-downward-rs) g)
|
||||
(define e1 (filter-event e (process-routes p)))
|
||||
(match e1
|
||||
[#f w]
|
||||
[(routing-update new-downward-rs)
|
||||
(if (equal? old-downward-rs new-downward-rs)
|
||||
w
|
||||
(transform-process pid (apply-transition pid (deliver-event e1 pid p) w)
|
||||
values
|
||||
(lambda (old-rs) new-downward-rs)))]
|
||||
[_ (apply-transition pid (deliver-event e1 pid p) w)])))
|
||||
|
||||
;; Behavior :> (Option Event) World -> Transition
|
||||
;; World's behavior function. Lifts and dispatches an incoming event
|
||||
;; to contained Processes.
|
||||
(define (world-handle-event e w)
|
||||
(if (or e (not (inert? w)))
|
||||
(if (or e (not (quiescent? w)))
|
||||
(sequence-transitions (transition (inject-event e w) '())
|
||||
dispatch-pending-events
|
||||
dispatch-events
|
||||
perform-actions
|
||||
(lambda (w) (or (step-children w) (transition w '()))))
|
||||
(step-children w)))
|
||||
|
||||
;; Event World -> World
|
||||
;; Translates an event from the World's container into PendingEvents
|
||||
;; suitable for its own contained Processes.
|
||||
(define (inject-event e w)
|
||||
(match e
|
||||
[#f w]
|
||||
[(routing-update g)
|
||||
(define old-downward (world-downward-gestalt w))
|
||||
(define new-downward (lift-gestalt (label-gestalt g 'out)))
|
||||
(issue-local-routing-update (update-full-gestalt
|
||||
(struct-copy world w [downward-gestalt new-downward]))
|
||||
(gestalt-union old-downward new-downward)
|
||||
#f)]
|
||||
[(routing-update routes)
|
||||
(issue-local-routing-update (struct-copy world w [downward-routes (lift-routes routes)]))]
|
||||
[(message body meta-level feedback?)
|
||||
(enqueue-pending-event (message body (+ meta-level 1) feedback?) w)]))
|
||||
(enqueue-event (message body (+ meta-level 1) feedback?) w)]))
|
||||
|
||||
;; Symbol
|
||||
;; Describes the routing implementation, for use in profiling, debugging etc.
|
||||
(define routing-implementation 'fastrouting)
|
||||
(define routing-implementation 'naive)
|
||||
|
|
|
|||
|
|
@ -1,36 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide (struct-out deduplicator)
|
||||
make-deduplicator
|
||||
deduplicator-accept
|
||||
deduplicator-expire)
|
||||
|
||||
(require racket/set)
|
||||
(require racket/match)
|
||||
(require "functional-queue.rkt")
|
||||
|
||||
(struct deduplicator (queue table ttl) #:transparent)
|
||||
|
||||
(define (make-deduplicator [ttl 10000])
|
||||
(deduplicator (make-queue) (set) ttl))
|
||||
|
||||
(define (deduplicator-expire d)
|
||||
(define now (current-inexact-milliseconds))
|
||||
(let loop ((d d))
|
||||
(match-define (deduplicator queue table ttl) d)
|
||||
(if (queue-empty? queue)
|
||||
d
|
||||
(let-values (((v q1) (dequeue queue)))
|
||||
(if (<= (car v) now)
|
||||
(loop (deduplicator q1 (set-remove table (cdr v)) ttl))
|
||||
d)))))
|
||||
|
||||
(define (deduplicator-accept d incoming)
|
||||
(let* ((d (deduplicator-expire d)))
|
||||
(match-define (deduplicator queue table ttl) d)
|
||||
(if (set-member? table incoming)
|
||||
(values #f d)
|
||||
(values #t (deduplicator (enqueue queue
|
||||
(cons (+ (current-inexact-milliseconds) ttl) incoming))
|
||||
(set-add table incoming)
|
||||
ttl)))))
|
||||
|
|
@ -1,169 +1,124 @@
|
|||
#lang racket/base
|
||||
;; A structure (and process!) for matching supply to demand via Gestalts.
|
||||
|
||||
(require racket/set)
|
||||
(require racket/match)
|
||||
(require "core.rkt")
|
||||
(require "gestalt.rkt")
|
||||
(require (only-in "route.rkt" matcher-key-set))
|
||||
(require "drivers/timer.rkt")
|
||||
(require "presence-detector.rkt")
|
||||
|
||||
(provide (except-out (struct-out demand-matcher) demand-matcher)
|
||||
(rename-out [make-demand-matcher demand-matcher])
|
||||
demand-matcher-update
|
||||
spawn-demand-matcher
|
||||
on-gestalt)
|
||||
spawn-demand-matcher)
|
||||
|
||||
;; A DemandMatcher keeps track of demand for services based on some
|
||||
;; Projection over a Gestalt, as well as a collection of functions
|
||||
;; that can be used to increase supply in response to increased
|
||||
;; demand, or handle a sudden drop in supply for which demand still
|
||||
;; exists.
|
||||
(struct demand-matcher (demand-is-subscription? ;; Boolean
|
||||
pattern ;; Pattern
|
||||
spec ;; CompiledProjection
|
||||
meta-level ;; Nat
|
||||
demand-level ;; Nat
|
||||
supply-level ;; Nat
|
||||
increase-handler ;; ChangeHandler
|
||||
decrease-handler ;; ChangeHandler
|
||||
current-demand ;; (Setof (Listof Any))
|
||||
current-supply) ;; (Setof (Listof Any))
|
||||
(struct demand-matcher (demand-is-subscription?
|
||||
pattern
|
||||
meta-level
|
||||
demand-level
|
||||
supply-level
|
||||
increase-handler
|
||||
decrease-handler
|
||||
state)
|
||||
#:transparent)
|
||||
|
||||
;; A ChangeHandler is a ((Constreeof Action) Any* -> (Constreeof Action)).
|
||||
;; It is called with an accumulator of actions so-far-computed as its
|
||||
;; first argument, and with a value for each capture in the
|
||||
;; DemandMatcher's projection as the remaining arguments.
|
||||
(define (unexpected-supply-decrease r)
|
||||
'())
|
||||
|
||||
;; ChangeHandler
|
||||
;; Default handler of unexpected supply decrease.
|
||||
(define (default-decrease-handler state . removed-captures)
|
||||
(define (default-decrease-handler removed state)
|
||||
state)
|
||||
|
||||
;; Constructs a DemandMatcher. The projection yields both the Pattern
|
||||
;; and CompiledProjection stored in the DemandMatcher.
|
||||
(define (make-demand-matcher demand-is-subscription? ;; Boolean
|
||||
projection ;; Projection
|
||||
meta-level ;; Nat
|
||||
demand-level ;; Nat
|
||||
supply-level ;; Nat
|
||||
increase-handler ;; ChangeHandler
|
||||
[decrease-handler default-decrease-handler]) ;; ChangeHandler
|
||||
(define (make-demand-matcher demand-is-subscription?
|
||||
pattern
|
||||
meta-level
|
||||
demand-level
|
||||
supply-level
|
||||
increase-handler
|
||||
[decrease-handler default-decrease-handler])
|
||||
(demand-matcher demand-is-subscription?
|
||||
(matcher-projection->pattern projection)
|
||||
(compile-matcher-projection projection)
|
||||
pattern
|
||||
meta-level
|
||||
demand-level
|
||||
supply-level
|
||||
increase-handler
|
||||
decrease-handler
|
||||
(set)
|
||||
(set)))
|
||||
(presence-detector)))
|
||||
|
||||
;; DemandMatcher (Constreeof Action) Gestalt -> (Values DemandMatcher (Constreeof Actions))
|
||||
;; Given a new Gestalt from the environment, projects it into supply and demand sets.
|
||||
;; Computes the differences between the new sets and the currently-cached sets, and
|
||||
;; calls the ChangeHandlers in response to increased unsatisfied demand and decreased
|
||||
;; demanded supply.
|
||||
(define (demand-matcher-update d s g)
|
||||
(match-define (demand-matcher demand-is-sub? _ spec ml dl sl inc-h dec-h old-demand old-supply) d)
|
||||
(define new-demand (matcher-key-set (gestalt-project* g ml dl (not demand-is-sub?) spec)))
|
||||
(define new-supply (matcher-key-set (gestalt-project* g ml sl demand-is-sub? spec)))
|
||||
(when (not new-demand)
|
||||
(error 'demand-matcher "Wildcard demand of ~a ~v at metalevel ~a, level ~a:\n~a"
|
||||
(if demand-is-sub? "subs" "advs")
|
||||
(demand-matcher-pattern d)
|
||||
ml
|
||||
dl
|
||||
(gestalt->pretty-string g)))
|
||||
(when (not new-supply)
|
||||
(error 'demand-matcher "Wildcard supply of ~a ~v at metalevel ~a, level ~a:\n~a"
|
||||
(if demand-is-sub? "advs" "subs")
|
||||
(demand-matcher-pattern d)
|
||||
ml
|
||||
sl
|
||||
(gestalt->pretty-string g)))
|
||||
(define demand+ (set-subtract (set-subtract new-demand old-demand) new-supply))
|
||||
(define supply- (set-intersect (set-subtract old-supply new-supply) new-demand))
|
||||
(define new-d (struct-copy demand-matcher d
|
||||
[current-demand new-demand]
|
||||
[current-supply new-supply]))
|
||||
(let* ((s (for/fold [(s s)] [(captures (in-set demand+))] (apply inc-h s captures)))
|
||||
(s (for/fold [(s s)] [(captures (in-set supply-))] (apply dec-h s captures))))
|
||||
(values new-d s)))
|
||||
(define (compute-detector demand? d)
|
||||
(route (if (demand-matcher-demand-is-subscription? d) (not demand?) demand?)
|
||||
(demand-matcher-pattern d)
|
||||
(demand-matcher-meta-level d)
|
||||
(+ 1 (max (demand-matcher-demand-level d)
|
||||
(demand-matcher-supply-level d)))))
|
||||
|
||||
;; For each route "changed" in routes, if changed is one of our
|
||||
;; monitored entities (a demand, if arrivals? is #t, or a supply
|
||||
;; otherwise), including both a pattern, meta-level, and level match,
|
||||
;; then search for matching peers (including level matching). If
|
||||
;; arrivals? is #t, then if there are no matching peers (i.e. supplies
|
||||
;; are not allocated), signel an increas in demand; otherwise, if
|
||||
;; there are any matching peers (i.e. demand remains), signal a
|
||||
;; decrease in supply.
|
||||
(define (incorporate-delta arrivals? routes d state)
|
||||
(define relevant-change-detector (compute-detector arrivals? d))
|
||||
(define expected-change-level
|
||||
(if arrivals? (demand-matcher-demand-level d) (demand-matcher-supply-level d)))
|
||||
(define expected-peer-level
|
||||
(if arrivals? (demand-matcher-supply-level d) (demand-matcher-demand-level d)))
|
||||
(for/fold ([s state]) ([changed routes])
|
||||
(if (= (route-level changed) expected-change-level)
|
||||
(match (intersect-routes (list changed) (list relevant-change-detector))
|
||||
['() s]
|
||||
[(list relevant-changed-route) ;; narrowed to relevancy by intersect-routes
|
||||
;; (log-info "incorporate-delta ~v ~v <--> ~v /// ~v"
|
||||
;; arrivals?
|
||||
;; relevant-changed-route
|
||||
;; relevant-change-detector
|
||||
;; (demand-matcher-state d))
|
||||
(define peer-detector
|
||||
(struct-copy route relevant-changed-route [level (+ 1 expected-peer-level)]))
|
||||
(define peer-exists?
|
||||
(ormap (lambda (r) (= (route-level r) expected-peer-level))
|
||||
(intersect-routes (presence-detector-routes (demand-matcher-state d))
|
||||
(list peer-detector))))
|
||||
;; (log-info "peer-exists? == ~v, peer-detector == ~v"
|
||||
;; peer-exists?
|
||||
;; peer-detector)
|
||||
(cond
|
||||
[(and arrivals? (not peer-exists?))
|
||||
((demand-matcher-increase-handler d) relevant-changed-route s)]
|
||||
[(and (not arrivals?) peer-exists?)
|
||||
((demand-matcher-decrease-handler d) relevant-changed-route s)]
|
||||
[else
|
||||
s])])
|
||||
s)))
|
||||
|
||||
(define (demand-matcher-update d state0 rs)
|
||||
(define-values (new-state added removed) (presence-detector-update (demand-matcher-state d) rs))
|
||||
(define new-d (struct-copy demand-matcher d [state new-state]))
|
||||
(define state1 (incorporate-delta #t added new-d state0))
|
||||
(define state2 (incorporate-delta #f removed new-d state1))
|
||||
(values new-d state2))
|
||||
|
||||
;; Behavior :> (Option Event) DemandMatcher -> Transition
|
||||
;; Handles events from the environment. Only cares about routing-updates.
|
||||
(define (demand-matcher-handle-event e d)
|
||||
(match e
|
||||
[(routing-update gestalt)
|
||||
(define-values (new-d actions) (demand-matcher-update d '() gestalt))
|
||||
[(routing-update routes)
|
||||
(define-values (new-d actions) (demand-matcher-update d '() routes))
|
||||
(transition new-d actions)]
|
||||
[_ #f]))
|
||||
|
||||
;; Any* -> (Constreeof Action)
|
||||
;; Default handler of unexpected supply decrease.
|
||||
;; Ignores the situation.
|
||||
(define (unexpected-supply-decrease . removed-captures)
|
||||
'())
|
||||
|
||||
;; Projection (Any* -> (Constreeof Action)) [(Any* -> (Constreeof Action))] -> Action
|
||||
;; Spawns a demand matcher actor.
|
||||
(define (spawn-demand-matcher projection
|
||||
(define (spawn-demand-matcher pattern
|
||||
increase-handler
|
||||
[decrease-handler unexpected-supply-decrease]
|
||||
#:demand-is-subscription? [demand-is-subscription? #f]
|
||||
#:demand-is-subscription? [demand-is-subscription? #t]
|
||||
#:meta-level [meta-level 0]
|
||||
#:demand-level [demand-level 0]
|
||||
#:supply-level [supply-level 0])
|
||||
(define d (make-demand-matcher demand-is-subscription?
|
||||
projection
|
||||
pattern
|
||||
meta-level
|
||||
demand-level
|
||||
supply-level
|
||||
(lambda (acs . rs) (cons (apply increase-handler rs) acs))
|
||||
(lambda (acs . rs) (cons (apply decrease-handler rs) acs))))
|
||||
(define observer-pattern (demand-matcher-pattern d))
|
||||
(define observer-level (+ 1 (max demand-level supply-level)))
|
||||
(lambda (r actions) (cons (increase-handler r) actions))
|
||||
(lambda (r actions) (cons (decrease-handler r) actions))))
|
||||
(spawn demand-matcher-handle-event
|
||||
d
|
||||
(gestalt-union (sub observer-pattern #:meta-level meta-level #:level observer-level)
|
||||
(pub observer-pattern #:meta-level meta-level #:level observer-level))))
|
||||
|
||||
;; (Gestalt (Option (Setof (Listof Value))) ... -> (Option (Constreeof Action)))
|
||||
;; Gestalt GestaltProjection ...
|
||||
;; -> Action
|
||||
;; Spawns a process that observes the given projections. Any time the
|
||||
;; environment's gestalt changes in a relevant way, calls
|
||||
;; check-and-maybe-spawn-fn with the aggregate gestalt and the
|
||||
;; projection results. If check-and-maybe-spawn-fn returns #f,
|
||||
;; continues to wait; otherwise, takes the action(s) returned, and
|
||||
;; quits.
|
||||
(define (on-gestalt #:timeout-msec [timeout-msec #f]
|
||||
#:on-timeout [timeout-handler (lambda () '())]
|
||||
check-and-maybe-spawn-fn
|
||||
base-gestalt
|
||||
. gestalt-projections)
|
||||
(define timer-id (gensym 'on-gestalt))
|
||||
(define aggregate-gestalt
|
||||
(apply gestalt-union
|
||||
base-gestalt
|
||||
(map projection->gestalt gestalt-projections)))
|
||||
(list
|
||||
(when timeout-msec (send (set-timer timer-id timeout-msec 'relative)))
|
||||
(spawn (lambda (e s)
|
||||
(match e
|
||||
[(routing-update g)
|
||||
(define projection-results
|
||||
(map (lambda (p) (gestalt-project/keys g p)) gestalt-projections))
|
||||
(define maybe-spawn (apply check-and-maybe-spawn-fn
|
||||
aggregate-gestalt
|
||||
projection-results))
|
||||
(transition s (when maybe-spawn (list maybe-spawn (quit))))]
|
||||
[(message (timer-expired _ _) _ _)
|
||||
(transition s (list (timeout-handler) (quit)))]
|
||||
[_ #f]))
|
||||
(void)
|
||||
(gestalt-union aggregate-gestalt
|
||||
(sub (timer-expired timer-id ?))))))
|
||||
(list (compute-detector #t d)
|
||||
(compute-detector #f d))))
|
||||
|
|
|
|||
|
|
@ -1,188 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(require racket/match)
|
||||
(require (prefix-in tcp: racket/tcp))
|
||||
(require (only-in racket/port read-bytes-avail!-evt))
|
||||
(require "../main.rkt")
|
||||
(require "../demand-matcher.rkt")
|
||||
(require "../exn-util.rkt")
|
||||
|
||||
(require racket/unit)
|
||||
(require net/tcp-sig)
|
||||
(require net/tcp-unit)
|
||||
|
||||
(provide (struct-out tcp-address)
|
||||
(struct-out tcp-handle)
|
||||
(struct-out tcp-listener)
|
||||
(struct-out tcp-channel)
|
||||
spawn-tcp-driver)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Protocol messages
|
||||
|
||||
(struct tcp-address (host port) #:prefab)
|
||||
(struct tcp-handle (id) #:prefab)
|
||||
(struct tcp-listener (port) #:prefab)
|
||||
|
||||
(struct tcp-channel (source destination subpacket) #:prefab)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Ground-level communication messages
|
||||
|
||||
(struct tcp-accepted (remote-addr local-addr cin cout) #:prefab)
|
||||
;; tcp-channel does double-duty as a ground-level message as well
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Driver
|
||||
|
||||
(define (spawn-tcp-driver)
|
||||
(list (spawn-demand-matcher (tcp-channel ? (?! (tcp-listener ?)) ?)
|
||||
#:demand-is-subscription? #t
|
||||
#:demand-level 1
|
||||
#:supply-level 2
|
||||
spawn-tcp-listener)
|
||||
(spawn-demand-matcher (tcp-channel (?! (tcp-handle ?)) (?! (tcp-address ? ?)) ?)
|
||||
spawn-tcp-connection)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Listener
|
||||
|
||||
(struct listener-state (control-ch server-addr) #:transparent)
|
||||
|
||||
(define (tcp-listener-thread control-ch listener server-addr)
|
||||
(let loop ((blocked? #t))
|
||||
(sync (handle-evt control-ch
|
||||
(match-lambda
|
||||
['unblock (loop #f)]
|
||||
['quit (void)]))
|
||||
(if blocked?
|
||||
never-evt
|
||||
(handle-evt (tcp:tcp-accept-evt listener)
|
||||
(lambda (cin+cout)
|
||||
(match-define (list cin cout) cin+cout)
|
||||
(define-values (local-hostname local-port remote-hostname remote-port)
|
||||
(tcp:tcp-addresses cin #t))
|
||||
(send-ground-message
|
||||
(tcp-accepted (tcp-address remote-hostname remote-port)
|
||||
server-addr
|
||||
cin
|
||||
cout))
|
||||
(loop blocked?))))))
|
||||
(tcp:tcp-close listener))
|
||||
|
||||
(define (tcp-listener-behavior e state)
|
||||
(match e
|
||||
[(routing-update g)
|
||||
(match-define (listener-state control-ch server-addr) state)
|
||||
(and control-ch
|
||||
(if (gestalt-empty? (gestalt-filter g (pub (tcp-channel ? server-addr ?) #:level 2)))
|
||||
(begin (channel-put control-ch 'quit)
|
||||
(transition (struct-copy listener-state state [control-ch #f]) (quit)))
|
||||
(begin (channel-put control-ch 'unblock)
|
||||
#f)))]
|
||||
[(message (tcp-accepted remote-addr _ cin cout) 1 #f)
|
||||
(transition state (spawn-connection (listener-state-server-addr state)
|
||||
remote-addr
|
||||
cin
|
||||
cout))]
|
||||
[_ #f]))
|
||||
|
||||
(define (spawn-tcp-listener server-addr)
|
||||
(match-define (tcp-listener port) server-addr)
|
||||
(define listener (tcp:tcp-listen port 128 #t))
|
||||
(define control-ch (make-channel))
|
||||
(thread (lambda () (tcp-listener-thread control-ch listener server-addr)))
|
||||
(spawn tcp-listener-behavior
|
||||
(listener-state control-ch server-addr)
|
||||
(gestalt-union (pub (tcp-channel ? server-addr ?) #:level 2)
|
||||
(sub (tcp-accepted ? server-addr ? ?) #:meta-level 1))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Outbound Connection
|
||||
|
||||
(define (spawn-tcp-connection local-addr remote-addr)
|
||||
(match-define (tcp-address remote-hostname remote-port) remote-addr)
|
||||
(define-values (cin cout)
|
||||
(with-handlers ([exn:fail:network? (lambda (e)
|
||||
;; TODO: it'd be nice to
|
||||
;; somehow communicate the
|
||||
;; actual error to the local
|
||||
;; peer.
|
||||
(log-error "~a" (exn->string e))
|
||||
(define o (open-output-string))
|
||||
(close-output-port o)
|
||||
(values (open-input-string "")
|
||||
o))])
|
||||
(tcp:tcp-connect remote-hostname remote-port)))
|
||||
(spawn-connection local-addr remote-addr cin cout))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Connection
|
||||
|
||||
(struct connection-state (seen-peer? control-ch cout) #:transparent)
|
||||
|
||||
(define (read-bytes-avail-evt len input-port)
|
||||
(guard-evt
|
||||
(lambda ()
|
||||
(let ([bstr (make-bytes len)])
|
||||
(handle-evt
|
||||
(read-bytes-avail!-evt bstr input-port)
|
||||
(lambda (v)
|
||||
(if (number? v)
|
||||
(if (= v len) bstr (subbytes bstr 0 v))
|
||||
v)))))))
|
||||
|
||||
(define (tcp-connection-thread remote-addr local-addr control-ch cin)
|
||||
(let loop ((blocked? #t))
|
||||
(sync (handle-evt control-ch
|
||||
(match-lambda
|
||||
['unblock (loop #f)]
|
||||
['quit (void)]))
|
||||
(if blocked?
|
||||
never-evt
|
||||
(handle-evt (read-bytes-avail-evt 32768 cin)
|
||||
(lambda (eof-or-bs)
|
||||
(send-ground-message (tcp-channel remote-addr local-addr eof-or-bs))
|
||||
(loop (or blocked? (eof-object? eof-or-bs))))))))
|
||||
(close-input-port cin))
|
||||
|
||||
(define (shutdown-connection state)
|
||||
(match-define (connection-state _ control-ch cout) state)
|
||||
(when control-ch (channel-put control-ch 'quit))
|
||||
(when cout (close-output-port cout))
|
||||
(transition (struct-copy connection-state state [control-ch #f] [cout #f]) (quit)))
|
||||
|
||||
(define (tcp-connection e state)
|
||||
(with-handlers [((lambda (exn) #t)
|
||||
(lambda (exn)
|
||||
(shutdown-connection state)
|
||||
(raise exn)))]
|
||||
(match e
|
||||
[(message (tcp-channel remote-addr local-addr (? eof-object?)) 1 #f)
|
||||
(shutdown-connection state)]
|
||||
[(message (tcp-channel remote-addr local-addr (? bytes? bs)) 1 #f)
|
||||
(transition state (send (tcp-channel remote-addr local-addr bs)))]
|
||||
[(message (tcp-channel _ _ bs) 0 #f)
|
||||
(write-bytes bs (connection-state-cout state))
|
||||
(flush-output (connection-state-cout state))
|
||||
#f]
|
||||
[(routing-update g)
|
||||
(cond
|
||||
[(and (connection-state-seen-peer? state) (gestalt-empty? g))
|
||||
(shutdown-connection state)]
|
||||
[(and (not (connection-state-seen-peer? state)) (not (gestalt-empty? g)))
|
||||
(channel-put (connection-state-control-ch state) 'unblock)
|
||||
(transition (struct-copy connection-state state [seen-peer? #t]) '())]
|
||||
[else
|
||||
#f])]
|
||||
[#f #f])))
|
||||
|
||||
(define (spawn-connection local-addr remote-addr cin cout)
|
||||
(define control-ch (make-channel))
|
||||
(thread (lambda () (tcp-connection-thread remote-addr local-addr control-ch cin)))
|
||||
(spawn tcp-connection
|
||||
(connection-state #f control-ch cout)
|
||||
(gestalt-union (pub (tcp-channel remote-addr local-addr ?))
|
||||
(sub (tcp-channel local-addr remote-addr ?))
|
||||
(pub (tcp-channel remote-addr local-addr ?) #:level 1)
|
||||
(sub (tcp-channel remote-addr local-addr ?) #:meta-level 1))))
|
||||
|
|
@ -19,43 +19,15 @@
|
|||
(struct set-timer (label msecs kind) #:prefab)
|
||||
(struct timer-expired (label msecs) #:prefab)
|
||||
|
||||
(define (spawn-timer-driver)
|
||||
(actor #:name timer-driver
|
||||
#:state [count 0]
|
||||
(struct driver-state (heap) #:transparent)
|
||||
|
||||
(define control-ch (make-channel))
|
||||
(thread (lambda () (timer-driver-thread-main control-ch)))
|
||||
|
||||
(subscribe ($ expiry (timer-expired ? ?))
|
||||
#:meta-level 1
|
||||
#:when (positive? count)
|
||||
(send expiry)
|
||||
#:update [count (- count 1)]
|
||||
#:update-routes) ;; TODO: only update-routes when count is zero
|
||||
|
||||
(subscribe ($ instruction (set-timer ? ? ?))
|
||||
(channel-put control-ch instruction)
|
||||
#:update [count (+ count 1)]
|
||||
#:update-routes))) ;; TODO: only update-routes when count was zero
|
||||
|
||||
(define (timer-driver-thread-main control-ch)
|
||||
(define heap (make-timer-heap))
|
||||
(let loop ()
|
||||
(sync (match (next-timer heap)
|
||||
[#f never-evt]
|
||||
[t (handle-evt (timer-evt (pending-timer-deadline t))
|
||||
(lambda (now)
|
||||
(for-each send-ground-message (fire-timers! heap now))
|
||||
(loop)))])
|
||||
(handle-evt control-ch
|
||||
(match-lambda
|
||||
[(set-timer label msecs 'relative)
|
||||
(install-timer! heap label (+ (current-inexact-milliseconds) msecs))
|
||||
(loop)]
|
||||
[(set-timer label msecs 'absolute)
|
||||
(install-timer! heap label msecs)
|
||||
(loop)]
|
||||
['quit (void)])))))
|
||||
;; Racket's alarm-evt is almost the right design for timeouts: its
|
||||
;; synchronisation value should be the (or some) value of the clock
|
||||
;; after the asked-for time. That way it serves as timeout and
|
||||
;; clock-reader in one.
|
||||
(define (timer-evt msecs)
|
||||
(wrap-evt (alarm-evt msecs)
|
||||
(lambda (_) (current-inexact-milliseconds))))
|
||||
|
||||
(define (make-timer-heap)
|
||||
(make-heap (lambda (t1 t2) (<= (pending-timer-deadline t1) (pending-timer-deadline t2)))))
|
||||
|
|
@ -70,18 +42,38 @@
|
|||
(let ((m (heap-min heap)))
|
||||
(if (<= (pending-timer-deadline m) now)
|
||||
(begin (heap-remove-min! heap)
|
||||
(cons (timer-expired (pending-timer-label m) now)
|
||||
(cons (send (timer-expired (pending-timer-label m) now))
|
||||
(fire-timers! heap now)))
|
||||
'()))))
|
||||
|
||||
(define (install-timer! heap label deadline)
|
||||
(define now (current-inexact-milliseconds))
|
||||
(heap-add! heap (pending-timer deadline label)))
|
||||
(define (timer-subscriptions s)
|
||||
(define t (next-timer (driver-state-heap s)))
|
||||
(gestalt-union (sub (set-timer ? ? 'relative))
|
||||
(sub (set-timer ? ? 'absolute))
|
||||
(pub (timer-expired ? ?))
|
||||
(if t
|
||||
(sub (event (timer-evt (pending-timer-deadline t)) ?) #:meta-level 1)
|
||||
(gestalt-empty))))
|
||||
|
||||
;; Racket's alarm-evt is almost the right design for timeouts: its
|
||||
;; synchronisation value should be the (or some) value of the clock
|
||||
;; after the asked-for time. That way it serves as timeout and
|
||||
;; clock-reader in one.
|
||||
(define (timer-evt msecs)
|
||||
(handle-evt (alarm-evt msecs)
|
||||
(lambda (_) (current-inexact-milliseconds))))
|
||||
(define (spawn-timer-driver)
|
||||
(define s (driver-state (make-timer-heap)))
|
||||
(spawn timer-driver
|
||||
s
|
||||
(timer-subscriptions s)))
|
||||
|
||||
(define (timer-driver e s)
|
||||
(match e
|
||||
[(message (event _ (list now)) 1 #f)
|
||||
(define actions (fire-timers! (driver-state-heap s) now))
|
||||
;; Note: compute to-send before recursing, because of side-effects on heap
|
||||
(transition s (list (routing-update (timer-subscriptions s)) actions))]
|
||||
[(message (set-timer label msecs 'relative) 0 #f)
|
||||
(install-timer! s label (+ (current-inexact-milliseconds) msecs))]
|
||||
[(message (set-timer label msecs 'absolute) 0 #f)
|
||||
(install-timer! s label msecs)]
|
||||
[_ #f]))
|
||||
|
||||
(define (install-timer! s label deadline)
|
||||
(define now (current-inexact-milliseconds))
|
||||
(heap-add! (driver-state-heap s) (pending-timer deadline label))
|
||||
(transition s (routing-update (timer-subscriptions s))))
|
||||
|
|
|
|||
|
|
@ -1,92 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(require racket/match)
|
||||
(require (prefix-in udp: racket/udp))
|
||||
(require "../main.rkt")
|
||||
(require "../demand-matcher.rkt")
|
||||
|
||||
(provide (struct-out udp-remote-address)
|
||||
(struct-out udp-handle)
|
||||
(struct-out udp-listener)
|
||||
udp-address?
|
||||
udp-local-address?
|
||||
(struct-out udp-packet)
|
||||
spawn-udp-driver)
|
||||
|
||||
;; A UdpAddress is one of
|
||||
;; -- a (udp-address String Uint16), representing a remote socket
|
||||
;; -- a (udp-handle Any), representing a local socket on a kernel-assigned port
|
||||
;; -- a (udp-listener Uint16), representing a local socket on a user-assigned port
|
||||
;; Note that udp-handle-ids must be chosen carefully: they are scoped
|
||||
;; to the local VM, i.e. shared between processes in that VM, so
|
||||
;; processes must make sure not to accidentally clash in handle ID
|
||||
;; selection.
|
||||
(struct udp-remote-address (host port) #:prefab)
|
||||
(struct udp-handle (id) #:prefab)
|
||||
(struct udp-listener (port) #:prefab)
|
||||
|
||||
(define (udp-address? x)
|
||||
(or (udp-remote-address? x)
|
||||
(udp-local-address? x)))
|
||||
|
||||
(define (udp-local-address? x)
|
||||
(or (udp-handle? x)
|
||||
(udp-listener? x)))
|
||||
|
||||
;; A UdpPacket is a (udp-packet UdpAddress UdpAddress Bytes), and
|
||||
;; represents a packet appearing on our local "subnet" of the full UDP
|
||||
;; network, complete with source, destination and contents.
|
||||
(struct udp-packet (source destination body) #:prefab)
|
||||
|
||||
;; -> Action
|
||||
;; Spawns a process acting as a UDP socket factory.
|
||||
(define (spawn-udp-driver)
|
||||
(list
|
||||
(spawn-demand-matcher (udp-packet ? (?! (udp-listener ?)) ?)
|
||||
#:demand-is-subscription? #t
|
||||
spawn-udp-socket)
|
||||
(spawn-demand-matcher (udp-packet ? (?! (udp-handle ?)) ?)
|
||||
#:demand-is-subscription? #t
|
||||
spawn-udp-socket)))
|
||||
|
||||
;; UdpLocalAddress -> Action
|
||||
(define (spawn-udp-socket local-addr)
|
||||
(define socket (udp:udp-open-socket #f #f))
|
||||
|
||||
(match local-addr
|
||||
[(udp-listener port) (udp:udp-bind! socket #f port)]
|
||||
[(udp-handle _) (udp:udp-bind! socket #f 0)]) ;; kernel-allocated port number
|
||||
|
||||
(define control-ch (make-channel))
|
||||
(thread (lambda () (udp-receiver-thread local-addr socket control-ch)))
|
||||
|
||||
(spawn (lambda (e s)
|
||||
(match e
|
||||
[(routing-update g)
|
||||
(transition s (when (gestalt-empty? g) (quit)))]
|
||||
[(message (? udp-packet? p) 1 #f)
|
||||
(transition s (send p))]
|
||||
[(message (udp-packet _ (udp-remote-address host port) body) 0 #f)
|
||||
(udp:udp-send-to socket host port body)
|
||||
#f]
|
||||
[_ #f]))
|
||||
(void)
|
||||
(gestalt-union (sub (udp-packet ? local-addr ?) #:meta-level 1)
|
||||
(sub (udp-packet local-addr (udp-remote-address ? ?) ?))
|
||||
(pub (udp-packet (udp-remote-address ? ?) local-addr ?))
|
||||
(pub (udp-packet (udp-remote-address ? ?) local-addr ?) #:level 1))))
|
||||
|
||||
;; UdpLocalAddress UdpSocket Channel -> Void
|
||||
(define (udp-receiver-thread local-addr socket control-ch)
|
||||
(define buffer (make-bytes 65536))
|
||||
(let loop ()
|
||||
(sync (handle-evt control-ch (match-lambda ['quit (void)]))
|
||||
(handle-evt (udp:udp-receive!-evt socket buffer)
|
||||
(lambda (receive-results)
|
||||
(match-define (list len source-hostname source-port) receive-results)
|
||||
(send-ground-message
|
||||
(udp-packet (udp-remote-address source-hostname source-port)
|
||||
local-addr
|
||||
(subbytes buffer 0 len)))
|
||||
(loop)))))
|
||||
(udp:udp-close socket))
|
||||
|
|
@ -2,7 +2,6 @@
|
|||
|
||||
(require racket/match)
|
||||
(require net/rfc6455)
|
||||
(require (only-in net/rfc6455/conn-api ws-conn-base-ip))
|
||||
(require "../main.rkt")
|
||||
(require "../demand-matcher.rkt")
|
||||
|
||||
|
|
@ -10,12 +9,9 @@
|
|||
(require net/tcp-sig)
|
||||
(require net/tcp-unit)
|
||||
(require net/ssl-tcp-unit)
|
||||
(require net/url)
|
||||
|
||||
(provide (struct-out websocket-remote-client)
|
||||
(struct-out websocket-local-server)
|
||||
(struct-out websocket-local-client)
|
||||
(struct-out websocket-remote-server)
|
||||
(struct-out websocket-ssl-options)
|
||||
(struct-out websocket-message)
|
||||
spawn-websocket-driver)
|
||||
|
|
@ -25,31 +21,19 @@
|
|||
|
||||
(struct websocket-remote-client (id) #:prefab)
|
||||
(struct websocket-local-server (port ssl-options) #:prefab)
|
||||
(struct websocket-local-client (id) #:prefab)
|
||||
(struct websocket-remote-server (url) #:prefab)
|
||||
(struct websocket-ssl-options (cert-file key-file) #:prefab)
|
||||
(struct websocket-message (from to body) #:prefab)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Ground-level communication messages
|
||||
|
||||
(struct websocket-connection (id local-addr remote-addr connection control-ch) #:prefab)
|
||||
(struct websocket-incoming-message (id message) #:prefab)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Driver
|
||||
|
||||
(define (spawn-websocket-driver)
|
||||
(list
|
||||
(spawn-demand-matcher (websocket-message ? (?! (websocket-local-server ? ?)) ?)
|
||||
#:demand-is-subscription? #t
|
||||
#:demand-level 1
|
||||
#:supply-level 2
|
||||
spawn-websocket-listener)
|
||||
(spawn-demand-matcher (websocket-message (?! (websocket-local-client ?))
|
||||
(?! (websocket-remote-server ?))
|
||||
?)
|
||||
spawn-websocket-connection)))
|
||||
(spawn-demand-matcher (websocket-message ? (websocket-local-server ? ?) ?)
|
||||
#:demand-level 1
|
||||
#:supply-level 2
|
||||
(match-lambda
|
||||
[(route _ (websocket-message _ server-addr _) _ _)
|
||||
(spawn-websocket-listener server-addr)])))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Listener
|
||||
|
|
@ -58,39 +42,24 @@
|
|||
|
||||
(define (websocket-listener e state)
|
||||
(match e
|
||||
[(routing-update g)
|
||||
[(routing-update routes)
|
||||
(match-define (listener-state shutdown-procedure server-addr) state)
|
||||
(if (gestalt-empty? (gestalt-filter g (pub (websocket-message ? server-addr ?) #:level 2)))
|
||||
(define peer-listener-route (pub (websocket-message ? server-addr ?) #:level 2))
|
||||
(if (for/or ((r routes)) (pair? (intersect-routes (list r) (list peer-listener-route))))
|
||||
#f
|
||||
(begin (when shutdown-procedure (shutdown-procedure))
|
||||
(transition (struct-copy listener-state state [shutdown-procedure #f]) (quit)))
|
||||
#f)]
|
||||
[(message (websocket-connection id local-addr remote-addr c control-ch) 1 #f)
|
||||
(transition state (spawn-connection local-addr remote-addr id c control-ch))]
|
||||
(transition (struct-copy listener-state state [shutdown-procedure #f]) (quit))))]
|
||||
[(message (event _ (list (list c connection-shutdown-procedure))) 1 #f)
|
||||
(transition state
|
||||
(spawn-connection (listener-state-server-addr state)
|
||||
c
|
||||
connection-shutdown-procedure))]
|
||||
[_ #f]))
|
||||
|
||||
(define ((connection-handler server-addr) c dummy-state)
|
||||
(define control-ch (make-channel))
|
||||
(define id (gensym 'ws))
|
||||
(send-ground-message
|
||||
(websocket-connection id server-addr (websocket-remote-client id) c control-ch))
|
||||
(connection-thread-loop control-ch c id))
|
||||
|
||||
(define (connection-thread-loop control-ch c id)
|
||||
(define c-input-port (ws-conn-base-ip c))
|
||||
(let loop ((blocked? #t))
|
||||
(sync (handle-evt control-ch
|
||||
(match-lambda
|
||||
['unblock (loop #f)]
|
||||
['quit (void)]))
|
||||
(if blocked?
|
||||
never-evt
|
||||
(handle-evt c-input-port
|
||||
(lambda (dummy)
|
||||
(define msg
|
||||
(with-handlers ([exn:fail:network? (lambda (e) eof)])
|
||||
(ws-recv c #:payload-type 'text)))
|
||||
(send-ground-message (websocket-incoming-message id msg))
|
||||
(loop (or blocked? (eof-object? msg))))))))
|
||||
(define ((connection-handler listener-ch) c dummy-state)
|
||||
(define connection-ch (make-channel))
|
||||
(channel-put listener-ch (list c (lambda () (channel-put connection-ch #t))))
|
||||
(channel-get connection-ch)
|
||||
(ws-close! c))
|
||||
|
||||
(define (ssl-options->ssl-tcp@ ssl-options)
|
||||
|
|
@ -103,83 +72,60 @@
|
|||
|
||||
(define (spawn-websocket-listener server-addr)
|
||||
(match-define (websocket-local-server port ssl-options) server-addr)
|
||||
(define ch (make-channel))
|
||||
(define shutdown-procedure (ws-serve #:port port
|
||||
#:tcp@ (if ssl-options
|
||||
(ssl-options->ssl-tcp@ ssl-options)
|
||||
tcp@)
|
||||
(connection-handler server-addr)))
|
||||
(connection-handler ch)))
|
||||
(spawn websocket-listener
|
||||
(listener-state shutdown-procedure server-addr)
|
||||
(gestalt-union (pub (websocket-message ? server-addr ?) #:level 2)
|
||||
(sub (websocket-connection ? server-addr ? ? ?) #:meta-level 1))))
|
||||
|
||||
(define (spawn-websocket-connection local-addr remote-addr)
|
||||
(match-define (websocket-remote-server url) remote-addr)
|
||||
(define id (gensym 'ws))
|
||||
(define control-ch (make-channel))
|
||||
(thread
|
||||
(lambda ()
|
||||
(log-info "Connecting to ~a ~a" url (current-inexact-milliseconds))
|
||||
(define c (with-handlers [(exn? values)] (ws-connect (string->url url))))
|
||||
(log-info "Connected to ~a ~a" url (current-inexact-milliseconds))
|
||||
(send-ground-message
|
||||
(websocket-connection id local-addr remote-addr c control-ch))
|
||||
(when (not (exn? c))
|
||||
(connection-thread-loop control-ch c id))))
|
||||
(actor #:state [buffered-messages-rev '()]
|
||||
|
||||
(subscribe (websocket-connection id local-addr remote-addr ($ c) control-ch)
|
||||
#:meta-level 1
|
||||
(list (when (not (exn? c))
|
||||
(for [(m (reverse buffered-messages-rev))] (ws-send! c m))
|
||||
(spawn-connection local-addr remote-addr id c control-ch))
|
||||
(quit)))
|
||||
|
||||
(subscribe (websocket-message local-addr remote-addr ($ m))
|
||||
#:update [buffered-messages-rev (cons m buffered-messages-rev)])))
|
||||
(list (pub (websocket-message ? server-addr ?) #:level 2)
|
||||
(sub (event ch ?) #:meta-level 1))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Connection
|
||||
|
||||
(struct connection-state (seen-peer? local-addr remote-addr c control-ch) #:transparent)
|
||||
(struct connection-state (seen-peer? local-addr server-addr c [shutdown-procedure #:mutable])
|
||||
#:transparent)
|
||||
|
||||
(define (shutdown-connection state)
|
||||
(transition (match (connection-state-control-ch state)
|
||||
[#f state]
|
||||
[ch (channel-put ch 'quit)
|
||||
(struct-copy connection-state state [control-ch #f])])
|
||||
(quit)))
|
||||
(when (connection-state-shutdown-procedure state)
|
||||
((connection-state-shutdown-procedure state))
|
||||
(set-connection-state-shutdown-procedure! state #f))
|
||||
(transition state (quit)))
|
||||
|
||||
(define (websocket-connection-behaviour e state)
|
||||
(define (websocket-connection e state)
|
||||
(with-handlers [((lambda (exn) #t)
|
||||
(lambda (exn)
|
||||
(shutdown-connection state)
|
||||
(raise exn)))]
|
||||
(lambda (exn) (shutdown-connection state)))]
|
||||
(match e
|
||||
[(message (websocket-incoming-message _ m) 1 #f)
|
||||
(if (eof-object? m)
|
||||
(shutdown-connection state)
|
||||
(transition state (send (websocket-message (connection-state-remote-addr state)
|
||||
(connection-state-local-addr state)
|
||||
m))))]
|
||||
[(message (event _ _) 1 #f)
|
||||
(match-define (connection-state seen-peer? local-addr server-addr c _) state)
|
||||
(and seen-peer?
|
||||
(let ((m (ws-recv c #:payload-type 'text)))
|
||||
(if (eof-object? m)
|
||||
(shutdown-connection state)
|
||||
(transition state (send (websocket-message local-addr
|
||||
server-addr
|
||||
m))))))]
|
||||
[(message (websocket-message _ _ m) 0 #f)
|
||||
(ws-send! (connection-state-c state) m)
|
||||
#f]
|
||||
[(routing-update g)
|
||||
[(routing-update routes)
|
||||
(cond
|
||||
[(and (connection-state-seen-peer? state) (gestalt-empty? g))
|
||||
[(and (connection-state-seen-peer? state) (null? routes))
|
||||
(shutdown-connection state)]
|
||||
[(and (not (connection-state-seen-peer? state)) (not (gestalt-empty? g)))
|
||||
(channel-put (connection-state-control-ch state) 'unblock)
|
||||
[(and (not (connection-state-seen-peer? state)) (pair? routes))
|
||||
(transition (struct-copy connection-state state [seen-peer? #t]) '())]
|
||||
[else
|
||||
#f])]
|
||||
[#f #f])))
|
||||
|
||||
(define (spawn-connection local-addr remote-addr id c control-ch)
|
||||
(spawn websocket-connection-behaviour
|
||||
(connection-state #f local-addr remote-addr c control-ch)
|
||||
(gestalt-union (pub (websocket-message remote-addr local-addr ?))
|
||||
(sub (websocket-message local-addr remote-addr ?))
|
||||
(sub (websocket-message local-addr remote-addr ?) #:level 1)
|
||||
(sub (websocket-incoming-message id ?) #:meta-level 1))))
|
||||
(define (spawn-connection server-addr c shutdown-procedure)
|
||||
(define local-addr (websocket-remote-client (gensym 'ws)))
|
||||
(spawn websocket-connection
|
||||
(connection-state #f local-addr server-addr c shutdown-procedure)
|
||||
(list (pub (websocket-message local-addr server-addr ?))
|
||||
(sub (websocket-message server-addr local-addr ?))
|
||||
(sub (websocket-message server-addr local-addr ?) #:level 1)
|
||||
(sub (event c ?) #:meta-level 1))))
|
||||
|
|
|
|||
|
|
@ -1,22 +0,0 @@
|
|||
#lang minimart
|
||||
;; Connects to the generic broker; use with broker.rkt and broker-client-pong.rkt.
|
||||
|
||||
(require minimart/drivers/timer)
|
||||
(require minimart/drivers/websocket)
|
||||
(require minimart/broker/client)
|
||||
|
||||
(spawn-timer-driver)
|
||||
(spawn-websocket-driver)
|
||||
(spawn-broker-client "broker" "ws://localhost:8000/")
|
||||
|
||||
(actor (advertise `("broker" 0 ("ping" ,?)))
|
||||
(subscribe `("broker" 0 ("pong" ,?))
|
||||
(log-info "Got pong - sending ping")
|
||||
(send `("broker" 0 ("ping" ,(current-inexact-milliseconds))))))
|
||||
|
||||
(actor (observe-subscribers `("broker" 0 ("ping" ,?))
|
||||
#:presence time-to-start?
|
||||
(when time-to-start?
|
||||
(log-info "---------------------------------------- KICKING OFF")
|
||||
(list (send `("broker" 0 ("ping" ,(current-inexact-milliseconds))))
|
||||
(quit)))))
|
||||
|
|
@ -1,15 +0,0 @@
|
|||
#lang minimart
|
||||
;; Connects to the generic broker; use with broker.rkt and broker-client-ping.rkt.
|
||||
|
||||
(require minimart/drivers/timer)
|
||||
(require minimart/drivers/websocket)
|
||||
(require minimart/broker/client)
|
||||
|
||||
(spawn-timer-driver)
|
||||
(spawn-websocket-driver)
|
||||
(spawn-broker-client "broker" "ws://localhost:8000/")
|
||||
|
||||
(actor (advertise `("broker" 0 ("pong" ,?)))
|
||||
(subscribe `("broker" 0 ("ping" ,?))
|
||||
(log-info "Got ping - sending pong")
|
||||
(send `("broker" 0 ("pong" ,(current-inexact-milliseconds))))))
|
||||
|
|
@ -1,12 +0,0 @@
|
|||
#lang minimart
|
||||
;; Generic broker for WebSockets-based minimart/marketplace communication.
|
||||
|
||||
(require minimart/drivers/timer)
|
||||
(require minimart/drivers/websocket)
|
||||
(require minimart/broker/server)
|
||||
|
||||
(spawn-timer-driver)
|
||||
(spawn-websocket-driver)
|
||||
(spawn-world
|
||||
(spawn-broker-server 8000)
|
||||
(spawn-broker-server 8443 (websocket-ssl-options "server-cert.pem" "private-key.pem")))
|
||||
|
|
@ -1,42 +0,0 @@
|
|||
#lang minimart
|
||||
|
||||
(require (only-in racket/string string-trim))
|
||||
(require "../drivers/tcp.rkt")
|
||||
(require "../demand-matcher.rkt")
|
||||
|
||||
(define (spawn-session them us)
|
||||
(actor #:name user-session
|
||||
|
||||
(define (send-to-remote fmt . vs)
|
||||
(send #:meta-level 1 (tcp-channel us them (string->bytes/utf-8 (apply format fmt vs)))))
|
||||
(define (say who fmt . vs)
|
||||
(unless (equal? who user) (send-to-remote "~a ~a\n" who (apply format fmt vs))))
|
||||
|
||||
(define user (gensym 'user))
|
||||
(send-to-remote "Welcome, ~a.\n" user)
|
||||
|
||||
(advertise (tcp-channel us them ?) #:meta-level 1)
|
||||
(subscribe `(,($ who) says ,($ what))
|
||||
(say who "says: ~a" what))
|
||||
|
||||
(advertise `(,user says ,?))
|
||||
(subscribe (tcp-channel them us ($ bs)) #:meta-level 1
|
||||
(send `(,user says ,(string-trim (bytes->string/utf-8 bs)))))
|
||||
|
||||
(observe-advertisers `(,($ who) says ,?)
|
||||
#:name present-user-names
|
||||
#:set who
|
||||
#:added arrived
|
||||
#:removed departed
|
||||
(for/list [(who arrived)] (say who "arrived."))
|
||||
(for/list [(who departed)] (say who "departed.")))
|
||||
|
||||
(observe-advertisers (tcp-channel them us ?) #:meta-level 1
|
||||
#:presence remote-present?
|
||||
(when (not remote-present?) (quit)))))
|
||||
|
||||
(spawn-tcp-driver)
|
||||
(spawn-world
|
||||
(spawn-demand-matcher (tcp-channel (?! (tcp-address ? ?)) (?! (tcp-listener 5999)) ?)
|
||||
#:meta-level 1
|
||||
spawn-session))
|
||||
|
|
@ -1,29 +0,0 @@
|
|||
#lang minimart
|
||||
|
||||
(require (only-in racket/port read-bytes-line-evt))
|
||||
(require "../drivers/tcp.rkt")
|
||||
|
||||
(define local-handle (tcp-handle 'chat))
|
||||
(define remote-handle (tcp-address "localhost" 5999))
|
||||
|
||||
(spawn-tcp-driver)
|
||||
|
||||
(actor #:name chat-client
|
||||
#:state [seen-remote? #f]
|
||||
|
||||
(define read-evt (read-bytes-line-evt (current-input-port) 'any))
|
||||
(subscribe (event read-evt (list ($ line)))
|
||||
#:meta-level 1
|
||||
(if (eof-object? line)
|
||||
(quit)
|
||||
(send (tcp-channel local-handle remote-handle line))))
|
||||
|
||||
(advertise (tcp-channel local-handle remote-handle ?))
|
||||
(subscribe (tcp-channel remote-handle local-handle ($ bs))
|
||||
(write-bytes bs)
|
||||
(flush-output))
|
||||
|
||||
(observe-advertisers (tcp-channel remote-handle local-handle ?)
|
||||
#:presence remote-present?
|
||||
(when (and (not remote-present?) seen-remote?) (quit))
|
||||
#:update [seen-remote? (or seen-remote? remote-present?)]))
|
||||
|
|
@ -1,30 +0,0 @@
|
|||
#lang minimart
|
||||
|
||||
(require (only-in racket/port read-bytes-line-evt))
|
||||
(require "../drivers/tcp.rkt")
|
||||
(require "../userland.rkt")
|
||||
|
||||
(define local-handle (tcp-handle 'chat))
|
||||
(define remote-handle (tcp-address "localhost" 5999))
|
||||
|
||||
(spawn-tcp-driver)
|
||||
|
||||
(userland-thread
|
||||
#:gestalt
|
||||
(gestalt-union (sub (event (read-bytes-line-evt (current-input-port) 'any) ?) #:meta-level 1)
|
||||
(sub (tcp-channel remote-handle local-handle ?))
|
||||
(sub (tcp-channel remote-handle local-handle ?) #:level 1)
|
||||
(pub (tcp-channel local-handle remote-handle ?)))
|
||||
(wait-for-gestalt (sub (tcp-channel remote-handle local-handle ?) #:level 1))
|
||||
(let loop ()
|
||||
(match (next-event)
|
||||
[(message (event _ (list (? eof-object?))) 1 #f)
|
||||
(do (quit))]
|
||||
[(message (event _ (list line)) 1 #f)
|
||||
(do (send (tcp-channel local-handle remote-handle line)))]
|
||||
[(message (tcp-channel _ _ bs) 0 #f)
|
||||
(write-bytes bs)
|
||||
(flush-output)]
|
||||
[(routing-update g)
|
||||
(when (gestalt-empty? g) (do (quit)))])
|
||||
(loop)))
|
||||
|
|
@ -1,30 +0,0 @@
|
|||
#lang minimart
|
||||
|
||||
(require (only-in racket/port read-bytes-line-evt))
|
||||
(require "../drivers/tcp.rkt")
|
||||
|
||||
(define local-handle (tcp-handle 'chat))
|
||||
(define remote-handle (tcp-address "localhost" 5999))
|
||||
|
||||
(spawn-tcp-driver)
|
||||
|
||||
(spawn (lambda (e seen-remote?)
|
||||
(match e
|
||||
[(message (event _ (list (? eof-object?))) 1 #f)
|
||||
(transition seen-remote? (quit))]
|
||||
[(message (event _ (list line)) 1 #f)
|
||||
(transition seen-remote? (send (tcp-channel local-handle remote-handle line)))]
|
||||
[(message (tcp-channel _ _ bs) 0 #f)
|
||||
(write-bytes bs)
|
||||
(flush-output)
|
||||
#f]
|
||||
[(routing-update g)
|
||||
(define remote-present? (not (gestalt-empty? g)))
|
||||
(transition (or seen-remote? remote-present?)
|
||||
(when (and (not remote-present?) seen-remote?) (quit)))]
|
||||
[#f #f]))
|
||||
#f
|
||||
(gestalt-union (sub (event (read-bytes-line-evt (current-input-port) 'any) ?) #:meta-level 1)
|
||||
(sub (tcp-channel remote-handle local-handle ?))
|
||||
(sub (tcp-channel remote-handle local-handle ?) #:level 1)
|
||||
(pub (tcp-channel local-handle remote-handle ?))))
|
||||
|
|
@ -1,50 +0,0 @@
|
|||
#lang minimart
|
||||
|
||||
(require racket/set)
|
||||
(require (only-in racket/string string-trim))
|
||||
(require "../drivers/tcp.rkt")
|
||||
(require "../demand-matcher.rkt")
|
||||
(require "../userland.rkt")
|
||||
|
||||
(define (spawn-session them us)
|
||||
(define user (gensym 'user))
|
||||
|
||||
(define (send-to-remote fmt . vs)
|
||||
(do (send #:meta-level 1 (tcp-channel us them (string->bytes/utf-8 (apply format fmt vs))))))
|
||||
|
||||
(define (say who fmt . vs)
|
||||
(unless (equal? who user) (send-to-remote "~a ~a\n" who (apply format fmt vs))))
|
||||
|
||||
(define tcp-gestalt (gestalt-union (pub (tcp-channel us them ?) #:meta-level 1)
|
||||
(sub (tcp-channel them us ?) #:meta-level 1 #:level 1)
|
||||
(sub (tcp-channel them us ?) #:meta-level 1)))
|
||||
|
||||
(define (gestalt->peers g) (gestalt-project/single g (project-pubs `(,(?!) says ,?))))
|
||||
|
||||
(userland-thread #:gestalt (gestalt-union tcp-gestalt
|
||||
(sub `(,? says ,?))
|
||||
(sub `(,? says ,?) #:level 1)
|
||||
(pub `(,user says ,?)))
|
||||
(define orig-peers (gestalt->peers (wait-for-gestalt tcp-gestalt)))
|
||||
(send-to-remote "Welcome, ~a.\n" user)
|
||||
(for/list [(who orig-peers)] (say who "arrived."))
|
||||
(let loop ((old-peers orig-peers))
|
||||
(match (next-event)
|
||||
[(message (tcp-channel _ _ bs) 1 #f)
|
||||
(do (send `(,user says ,(string-trim (bytes->string/utf-8 bs)))))
|
||||
(loop old-peers)]
|
||||
[(message `(,who says ,what) 0 #f)
|
||||
(say who "says: ~a" what)
|
||||
(loop old-peers)]
|
||||
[(routing-update g)
|
||||
(when (gestalt-empty? (gestalt-filter g tcp-gestalt)) (do (quit)))
|
||||
(define new-peers (gestalt->peers g))
|
||||
(for/list [(who (set-subtract new-peers old-peers))] (say who "arrived."))
|
||||
(for/list [(who (set-subtract old-peers new-peers))] (say who "departed."))
|
||||
(loop new-peers)]))))
|
||||
|
||||
(spawn-tcp-driver)
|
||||
(spawn-world
|
||||
(spawn-demand-matcher (tcp-channel (?! (tcp-address ? ?)) (?! (tcp-listener 5999)) ?)
|
||||
#:meta-level 1
|
||||
spawn-session))
|
||||
|
|
@ -1,55 +0,0 @@
|
|||
#lang minimart
|
||||
|
||||
(require racket/set)
|
||||
(require (only-in racket/string string-trim))
|
||||
(require "../drivers/tcp.rkt")
|
||||
(require "../demand-matcher.rkt")
|
||||
(require "../userland.rkt")
|
||||
|
||||
(define (spawn-session them us)
|
||||
(define (send-to-remote fmt . vs)
|
||||
(do (send #:meta-level 1 (tcp-channel us them (string->bytes/utf-8 (apply format fmt vs))))))
|
||||
|
||||
(define tcp-gestalt (gestalt-union (pub (tcp-channel us them ?) #:meta-level 1)
|
||||
(sub (tcp-channel them us ?) #:meta-level 1 #:level 1)
|
||||
(sub (tcp-channel them us ?) #:meta-level 1)))
|
||||
|
||||
(define (decode-input bs) (string-trim (bytes->string/utf-8 bs)))
|
||||
(define (read-chunk) (receive [(message (tcp-channel _ _ bs) 1 #f) (decode-input bs)]))
|
||||
|
||||
(userland-thread #:gestalt tcp-gestalt
|
||||
|
||||
(wait-for-gestalt tcp-gestalt)
|
||||
(send-to-remote "What is your name? > ")
|
||||
(define user (read-chunk))
|
||||
(send-to-remote "Welcome, ~a.\n" user)
|
||||
|
||||
(do (routing-update (gestalt-union tcp-gestalt
|
||||
(sub `(,? says ,?) #:level 1)
|
||||
(sub `(,? says ,?))
|
||||
(pub `(,user says ,?)))))
|
||||
|
||||
(define (say who fmt . vs)
|
||||
(unless (equal? who user)
|
||||
(send-to-remote "~a ~a\n" who (apply format fmt vs))))
|
||||
|
||||
(let loop ((old-peers (set)))
|
||||
(match (next-event)
|
||||
[(message (tcp-channel _ _ bs) 1 #f)
|
||||
(do (send `(,user says ,(decode-input bs))))
|
||||
(loop old-peers)]
|
||||
[(message `(,who says ,what) 0 #f)
|
||||
(say who "says: ~a" what)
|
||||
(loop old-peers)]
|
||||
[(routing-update g)
|
||||
(when (gestalt-empty? (gestalt-filter g tcp-gestalt)) (do (quit)))
|
||||
(define new-peers (gestalt-project/single g (project-pubs `(,(?!) says ,?))))
|
||||
(for/list [(who (set-subtract new-peers old-peers))] (say who "arrived."))
|
||||
(for/list [(who (set-subtract old-peers new-peers))] (say who "departed."))
|
||||
(loop new-peers)]))))
|
||||
|
||||
(spawn-tcp-driver)
|
||||
(spawn-world
|
||||
(spawn-demand-matcher (tcp-channel (?! (tcp-address ? ?)) (?! (tcp-listener 5999)) ?)
|
||||
#:meta-level 1
|
||||
spawn-session))
|
||||
|
|
@ -1,47 +0,0 @@
|
|||
#lang minimart
|
||||
|
||||
(require racket/set)
|
||||
(require (only-in racket/string string-trim))
|
||||
(require "../drivers/tcp.rkt")
|
||||
(require "../demand-matcher.rkt")
|
||||
|
||||
(define (spawn-session them us)
|
||||
(define user (gensym 'user))
|
||||
(define remote-detector (project-pubs #:meta-level 1 (?!)))
|
||||
(define peer-detector (project-pubs `(,(?!) says ,?)))
|
||||
(define (send-to-remote fmt . vs)
|
||||
(send #:meta-level 1 (tcp-channel us them (string->bytes/utf-8 (apply format fmt vs)))))
|
||||
(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 (lambda (e old-peers)
|
||||
(log-info "~a: ~v --> ~v" user e old-peers)
|
||||
(match e
|
||||
[(message (tcp-channel _ _ bs) 1 #f)
|
||||
(transition old-peers
|
||||
(send `(,user says ,(string-trim (bytes->string/utf-8 bs)))))]
|
||||
[(message `(,who says ,what) 0 #f)
|
||||
(transition old-peers (say who "says: ~a" what))]
|
||||
[(routing-update g)
|
||||
(define new-peers (gestalt-project/single g peer-detector))
|
||||
(transition
|
||||
new-peers
|
||||
(list (when (matcher-empty? (gestalt-project g remote-detector)) (quit))
|
||||
(for/list [(who (set-subtract new-peers old-peers))]
|
||||
(say who "arrived."))
|
||||
(for/list [(who (set-subtract old-peers new-peers))]
|
||||
(say who "departed."))))]
|
||||
[#f #f]))
|
||||
(set)
|
||||
(gestalt-union (sub `(,? says ,?))
|
||||
(sub `(,? says ,?) #:level 1)
|
||||
(pub `(,user says ,?))
|
||||
(sub (tcp-channel them us ?) #:meta-level 1)
|
||||
(sub (tcp-channel them us ?) #:meta-level 1 #:level 1)
|
||||
(pub (tcp-channel us them ?) #:meta-level 1)))))
|
||||
|
||||
(spawn-tcp-driver)
|
||||
(spawn-world
|
||||
(spawn-demand-matcher (tcp-channel (?! (tcp-address ? ?)) (?! (tcp-listener 5999)) ?)
|
||||
#:meta-level 1
|
||||
spawn-session))
|
||||
|
|
@ -3,22 +3,9 @@
|
|||
(require (only-in racket/port read-line-evt))
|
||||
(require "../drivers/timer.rkt")
|
||||
|
||||
(define (quasi-spy e s)
|
||||
(printf "----------------------------------------\n")
|
||||
(printf "QUASI-SPY:\n")
|
||||
(match e
|
||||
[(routing-update g) (pretty-print-gestalt g)]
|
||||
[other
|
||||
(write other)
|
||||
(newline)])
|
||||
(printf "========================================\n")
|
||||
#f)
|
||||
(spawn quasi-spy (void) (gestalt-union (sub ? #:level 10)
|
||||
(pub ? #:level 10)))
|
||||
|
||||
(define (r e s)
|
||||
(match e
|
||||
[(message body _ _) (transition s (send `(print (got ,body)) #:meta-level 1))]
|
||||
[(message body _ _) (transition s (send `(print got ,body) #:meta-level 1))]
|
||||
[_ #f]))
|
||||
|
||||
(define (b e n)
|
||||
|
|
@ -34,7 +21,7 @@
|
|||
(define (echoer e s)
|
||||
(match e
|
||||
[(message (event _ (list (? eof-object?))) _ _) (transition s (quit))]
|
||||
[(message (event _ (list line)) _ _) (transition s (send `(print (got-line ,line))))]
|
||||
[(message (event _ (list line)) _ _) (transition s (send `(print got-line ,line)))]
|
||||
[_ #f]))
|
||||
|
||||
(spawn echoer (void) (sub (event (read-line-evt (current-input-port) 'any) ?)
|
||||
|
|
@ -44,6 +31,8 @@
|
|||
(match e
|
||||
[(routing-update g)
|
||||
(printf "EMPTY? ~v\n" (gestalt-empty? g))
|
||||
(printf "REF:")
|
||||
(pretty-print-matcher (gestalt-ref g 0 0 #f) #:indent 4)
|
||||
(printf "INTERSECTED:\n")
|
||||
(pretty-print-gestalt (gestalt-filter g (pub (set-timer ? ? ?) #:level 1)))
|
||||
#f]
|
||||
|
|
@ -61,9 +50,9 @@
|
|||
|
||||
(define (printer e s)
|
||||
(match e
|
||||
[(message (list 'print v) _ _)
|
||||
[(message (cons 'print v) _ _)
|
||||
(log-info "PRINTER: ~a" v)
|
||||
#f]
|
||||
[_ #f]))
|
||||
|
||||
(spawn printer (void) (sub `(print ,?)))
|
||||
(spawn printer (void) (sub `(print . ,?)))
|
||||
|
|
|
|||
|
|
@ -5,20 +5,9 @@
|
|||
(require "../main.rkt")
|
||||
(require "../drivers/timer.rkt")
|
||||
|
||||
(define (quasi-spy e s)
|
||||
(printf "----------------------------------------\n")
|
||||
(printf "QUASI-SPY:\n")
|
||||
(match e
|
||||
[(routing-update g) (pretty-print-gestalt g)]
|
||||
[other
|
||||
(write other)
|
||||
(newline)])
|
||||
(printf "========================================\n")
|
||||
#f)
|
||||
|
||||
(define (r e s)
|
||||
(match e
|
||||
[(message body _ _) (transition s (send `(print (got ,body)) #:meta-level 1))]
|
||||
[(message body _ _) (transition s (send `(print got ,body) #:meta-level 1))]
|
||||
[_ #f]))
|
||||
|
||||
(define (b e n)
|
||||
|
|
@ -31,13 +20,15 @@
|
|||
(define (echoer e s)
|
||||
(match e
|
||||
[(message (event _ (list (? eof-object?))) _ _) (transition s (quit))]
|
||||
[(message (event _ (list line)) _ _) (transition s (send `(print (got-line ,line))))]
|
||||
[(message (event _ (list line)) _ _) (transition s (send `(print got-line ,line)))]
|
||||
[_ #f]))
|
||||
|
||||
(define (ticker e s)
|
||||
(match e
|
||||
[(routing-update g)
|
||||
(printf "EMPTY? ~v\n" (gestalt-empty? g))
|
||||
(printf "REF:")
|
||||
(pretty-print-matcher (gestalt-ref g 0 0 #f) #:indent 4)
|
||||
(printf "INTERSECTED:\n")
|
||||
(pretty-print-gestalt (gestalt-filter g (pub (set-timer ? ? ?) #:level 1)))
|
||||
#f]
|
||||
|
|
@ -50,14 +41,12 @@
|
|||
|
||||
(define (printer e s)
|
||||
(match e
|
||||
[(message (list 'print v) _ _)
|
||||
[(message (cons 'print v) _ _)
|
||||
(log-info "PRINTER: ~a" v)
|
||||
#f]
|
||||
[_ #f]))
|
||||
|
||||
(run-ground (spawn quasi-spy (void) (gestalt-union (sub ? #:level 10)
|
||||
(pub ? #:level 10)))
|
||||
(spawn-timer-driver)
|
||||
(run-ground (spawn-timer-driver)
|
||||
(send (set-timer 'tick 1000 'relative))
|
||||
(spawn ticker 1 (gestalt-union (pub (set-timer ? ? ?) #:level 1)
|
||||
(sub (timer-expired 'tick ?))))
|
||||
|
|
@ -65,4 +54,4 @@
|
|||
(spawn b 0))
|
||||
(spawn echoer (void) (sub (event (read-line-evt (current-input-port) 'any) ?)
|
||||
#:meta-level 1))
|
||||
(spawn printer (void) (sub `(print ,?))))
|
||||
(spawn printer (void) (sub `(print . ,?))))
|
||||
|
|
|
|||
|
|
@ -1,30 +0,0 @@
|
|||
#lang minimart
|
||||
|
||||
(require "../drivers/tcp.rkt")
|
||||
(require "../demand-matcher.rkt")
|
||||
|
||||
(spawn-tcp-driver)
|
||||
|
||||
(define server-id (tcp-listener 5999))
|
||||
|
||||
(define (spawn-connection-handler c)
|
||||
(log-info "spawn-connection-handler ~v" c)
|
||||
(define (connection-handler e n)
|
||||
(when e (log-info "connection-handler ~v: ~v /// ~v" c e n))
|
||||
(match e
|
||||
[(routing-update (? gestalt-empty?)) (transition n (quit))]
|
||||
[_
|
||||
(if (< n 20)
|
||||
(transition (+ n 1) (send (tcp-channel server-id c (string->bytes/utf-8 (format "msg ~v\n" n)))))
|
||||
#f)]))
|
||||
(spawn connection-handler
|
||||
0
|
||||
(gestalt-union (sub (tcp-channel c server-id ?))
|
||||
(sub (tcp-channel c server-id ?) #:level 1)
|
||||
(pub (tcp-channel server-id c ?)))))
|
||||
|
||||
(spawn-demand-matcher (tcp-channel (?! (tcp-address ? ?)) server-id ?)
|
||||
spawn-connection-handler
|
||||
(lambda (c)
|
||||
(log-info "Connection handler ~v decided to exit" c)
|
||||
'()))
|
||||
|
|
@ -1,35 +0,0 @@
|
|||
#lang minimart
|
||||
|
||||
(struct save (filename body) #:prefab)
|
||||
(struct contents (filename body) #:prefab)
|
||||
|
||||
(actor #:name file-server
|
||||
#:state [files (hash)]
|
||||
|
||||
(subscribe (save ($ filename) ($ body))
|
||||
#:update [files (hash-set files filename body)]
|
||||
#:update-routes)
|
||||
|
||||
(observe-subscribers (contents ($ filename) ?)
|
||||
#:level 1
|
||||
#:name observed-filenames
|
||||
#:set filename)
|
||||
|
||||
(for/advertise [(filename observed-filenames)
|
||||
#:when (hash-has-key? files filename)]
|
||||
(contents filename (hash-ref files filename))))
|
||||
|
||||
(define (spawn-file-watcher filename)
|
||||
(actor #:name observer-of-files
|
||||
(observe-advertisers (contents filename ($ file-contents))
|
||||
#:name file-contents
|
||||
#:set file-contents
|
||||
(printf "Contents of ~a: ~v\n" filename file-contents))))
|
||||
|
||||
(spawn-file-watcher 'a)
|
||||
(spawn-file-watcher 'b)
|
||||
(spawn-file-watcher 'c)
|
||||
(send (save 'a "first file"))
|
||||
(send (save 'b "second file"))
|
||||
(send (save 'c "third file"))
|
||||
(send (save 'b "second file, second version"))
|
||||
|
|
@ -1,11 +0,0 @@
|
|||
#lang minimart
|
||||
|
||||
(require "../drivers/udp.rkt")
|
||||
|
||||
(spawn-udp-driver)
|
||||
|
||||
(actor #:name echoer
|
||||
(subscribe (udp-packet ($ src) ($ dst (udp-listener 5999)) ($ body))
|
||||
(log-info "Got packet from ~v: ~v" src body)
|
||||
(define reply (string->bytes/utf-8 (format "You said: ~a" body)))
|
||||
(send (udp-packet dst src reply))))
|
||||
|
|
@ -9,24 +9,28 @@
|
|||
(define server-id (websocket-local-server 8081 (websocket-ssl-options "server-cert.pem"
|
||||
"private-key.pem")))
|
||||
|
||||
(spawn-demand-matcher (websocket-message any-client server-id ?)
|
||||
#:demand-is-subscription? #f
|
||||
(match-lambda ;; arrived-demand-route, i.e. new connection publisher
|
||||
[(route _ (websocket-message c _ _) _ _)
|
||||
(spawn-connection-handler c)]
|
||||
[_ '()])
|
||||
(lambda (departed-supply-route)
|
||||
(log-info "Connection handler decided to exit")
|
||||
'()))
|
||||
|
||||
(define (spawn-connection-handler c)
|
||||
(log-info "spawn-connection-handler ~v" c)
|
||||
(define (connection-handler e n)
|
||||
(when e (log-info "connection-handler ~v: ~v /// ~v" c e n))
|
||||
(match e
|
||||
[(routing-update (? gestalt-empty?)) (transition n (quit))]
|
||||
[(routing-update '()) (transition n (quit))]
|
||||
[_
|
||||
(if (< n 20)
|
||||
(transition (+ n 1) (send (websocket-message server-id c (format "msg ~v" n))))
|
||||
#f)]))
|
||||
(spawn connection-handler
|
||||
0
|
||||
(gestalt-union (sub (websocket-message c server-id ?))
|
||||
(sub (websocket-message c server-id ?) #:level 1)
|
||||
(pub (websocket-message server-id c ?)))))
|
||||
|
||||
(spawn-demand-matcher (websocket-message (?! any-client) server-id ?)
|
||||
spawn-connection-handler
|
||||
(lambda (c)
|
||||
(log-info "Connection handler ~v decided to exit" c)
|
||||
'()))
|
||||
(list (sub (websocket-message c server-id ?))
|
||||
(sub (websocket-message c server-id ?) #:level 1)
|
||||
(pub (websocket-message server-id c ?)))))
|
||||
|
|
|
|||
|
|
@ -8,24 +8,28 @@
|
|||
(define any-client (websocket-remote-client ?))
|
||||
(define server-id (websocket-local-server 8081 #f))
|
||||
|
||||
(spawn-demand-matcher (websocket-message any-client server-id ?)
|
||||
#:demand-is-subscription? #f
|
||||
(match-lambda ;; arrived-demand-route, i.e. new connection publisher
|
||||
[(route _ (websocket-message c _ _) _ _)
|
||||
(spawn-connection-handler c)]
|
||||
[_ '()])
|
||||
(lambda (departed-supply-route)
|
||||
(log-info "Connection handler decided to exit")
|
||||
'()))
|
||||
|
||||
(define (spawn-connection-handler c)
|
||||
(log-info "spawn-connection-handler ~v" c)
|
||||
(define (connection-handler e n)
|
||||
(when e (log-info "connection-handler ~v: ~v /// ~v" c e n))
|
||||
(match e
|
||||
[(routing-update (? gestalt-empty?)) (transition n (quit))]
|
||||
[(routing-update '()) (transition n (quit))]
|
||||
[_
|
||||
(if (< n 20)
|
||||
(transition (+ n 1) (send (websocket-message server-id c (format "msg ~v" n))))
|
||||
#f)]))
|
||||
(spawn connection-handler
|
||||
0
|
||||
(gestalt-union (sub (websocket-message c server-id ?))
|
||||
(sub (websocket-message c server-id ?) #:level 1)
|
||||
(pub (websocket-message server-id c ?)))))
|
||||
|
||||
(spawn-demand-matcher (websocket-message (?! any-client) server-id ?)
|
||||
spawn-connection-handler
|
||||
(lambda (c)
|
||||
(log-info "Connection handler ~v decided to exit" c)
|
||||
'()))
|
||||
(list (sub (websocket-message c server-id ?))
|
||||
(sub (websocket-message c server-id ?) #:level 1)
|
||||
(pub (websocket-message server-id c ?)))))
|
||||
|
|
|
|||
|
|
@ -1,8 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide exn->string)
|
||||
|
||||
(define (exn->string exn)
|
||||
(parameterize ([current-error-port (open-output-string)])
|
||||
((error-display-handler) (exn-message exn) exn)
|
||||
(get-output-string (current-error-port))))
|
||||
|
|
@ -4,7 +4,6 @@
|
|||
queue?
|
||||
enqueue
|
||||
enqueue-all
|
||||
queue-prepare-for-dequeue
|
||||
dequeue
|
||||
list->queue
|
||||
queue->list
|
||||
|
|
@ -27,13 +26,13 @@
|
|||
(queue (queue-head q)
|
||||
(append (reverse v) (queue-tail q))))
|
||||
|
||||
(define (queue-prepare-for-dequeue q)
|
||||
(define (shuffle q)
|
||||
(if (null? (queue-head q))
|
||||
(queue (reverse (queue-tail q)) '())
|
||||
q))
|
||||
|
||||
(define (dequeue q)
|
||||
(let ((q1 (queue-prepare-for-dequeue q)))
|
||||
(let ((q1 (shuffle q)))
|
||||
(values (car (queue-head q1))
|
||||
(queue (cdr (queue-head q1)) (queue-tail q1)))))
|
||||
|
||||
|
|
|
|||
|
|
@ -1,497 +0,0 @@
|
|||
#lang racket/base
|
||||
;; Gestalts: representations of (replicated) state.
|
||||
|
||||
(require racket/set)
|
||||
(require racket/match)
|
||||
(require (only-in racket/list make-list))
|
||||
(require (only-in racket/port with-output-to-string))
|
||||
|
||||
(require "route.rkt")
|
||||
(require "tset.rkt")
|
||||
|
||||
(provide (struct-out gestalt)
|
||||
(struct-out projection)
|
||||
gestalt-match-value
|
||||
|
||||
project-subs
|
||||
project-pubs
|
||||
projection?
|
||||
projection-spec
|
||||
projection->gestalt
|
||||
gestalt-project*
|
||||
gestalt-project
|
||||
gestalt-project/keys
|
||||
gestalt-project/single
|
||||
|
||||
drop-gestalt
|
||||
lift-gestalt
|
||||
simple-gestalt
|
||||
gestalt-empty
|
||||
gestalt-empty?
|
||||
gestalt-full
|
||||
gestalt-union*
|
||||
gestalt-union
|
||||
gestalt-filter
|
||||
gestalt-match
|
||||
gestalt-subtract
|
||||
gestalt-transform
|
||||
gestalt-matcher-transform
|
||||
strip-gestalt-label
|
||||
label-gestalt
|
||||
gestalt-level-count
|
||||
pretty-print-gestalt
|
||||
gestalt->pretty-string
|
||||
gestalt->jsexpr
|
||||
jsexpr->gestalt)
|
||||
|
||||
;; A Gestalt is a (gestalt (Listof Metalevel)), representing the total
|
||||
;; interests of a process or group of processes at all metalevels and
|
||||
;; levels.
|
||||
;;
|
||||
;; A Level is a (Pairof Matcher Matcher), representing active
|
||||
;; subscriptions and advertisements at a particular level and
|
||||
;; metalevel.
|
||||
;;
|
||||
;; A Metalevel is a (Listof Level), representing all Levels (ordered
|
||||
;; by level number) at a given metalevel.
|
||||
;;
|
||||
;; --
|
||||
;;
|
||||
;; The outer list of a Gestalt has an entry for each active metalevel,
|
||||
;; starting with metalevel 0 in the car.
|
||||
;;
|
||||
;; The middle list has an entry for each active level within its
|
||||
;; metalevel, starting with level 0 in the car.
|
||||
;;
|
||||
;; The inner pairs have cars holding matchers representing active
|
||||
;; subscriptions, and cdrs representing active advertisements.
|
||||
;;
|
||||
;; Each of the Matchers maps to (NonemptySetof PID).
|
||||
;;
|
||||
;; --
|
||||
;;
|
||||
;; "... a few standardised subsystems, identical from citizen to
|
||||
;; citizen. Two of these were channels for incoming data — one for
|
||||
;; gestalt, and one for linear, the two primary modalities of all
|
||||
;; Konishi citizens, distant descendants of vision and hearing."
|
||||
;; -- Greg Egan, "Diaspora"
|
||||
;; http://gregegan.customer.netspace.net.au/DIASPORA/01/Orphanogenesis.html
|
||||
;;
|
||||
(struct gestalt (metalevels)
|
||||
#:transparent
|
||||
#:methods gen:custom-write
|
||||
[(define (write-proc g port mode)
|
||||
(display "{{{" port)
|
||||
(pretty-print-gestalt g port)
|
||||
(display "}}}" port))])
|
||||
|
||||
;; Convention: A GestaltSet is a Gestalt where the Matchers map to #t
|
||||
;; instead of (NonemptySetof PID) or any other value.
|
||||
|
||||
;; A GestaltProjection is a single-metalevel, single-level fragment of
|
||||
;; a gestalt with capture-groups. See matcher-project in route.rkt.
|
||||
(struct projection (metalevel level get-advertisements? spec compiled))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;; (Listof X) Nat [-> X] -> X
|
||||
(define (safe-list-ref xs n [fail-thunk (lambda () (error 'safe-list-ref "No such index ~v" n))])
|
||||
(let loop ((xs xs) (n n))
|
||||
(match xs
|
||||
['() (fail-thunk)]
|
||||
[(cons x xs) (if (zero? n) x (loop xs (- n 1)))])))
|
||||
|
||||
;; (Listof X) -> (Listof X)
|
||||
;; ->> HISTORICAL IRONY <<-
|
||||
(define (safe-cdr xs)
|
||||
(if (null? xs)
|
||||
'()
|
||||
(cdr xs)))
|
||||
|
||||
;; X -> X (Listof X) -> (Listof X)
|
||||
;; Conses a onto d, unless d is '() and a is the special unit value.
|
||||
(define ((guarded-cons unit) a d)
|
||||
(if (and (null? d) (equal? a unit))
|
||||
'()
|
||||
(cons a d)))
|
||||
|
||||
;; Level
|
||||
;; The empty level, matching no messages.
|
||||
(define empty-level '(#f . #f))
|
||||
|
||||
;; The empty metalevel, matching no messages at any level.
|
||||
(define empty-metalevel '())
|
||||
|
||||
;; Level Metalevel -> Metalevel
|
||||
;; Only adds to its second argument if its first is nonempty.
|
||||
(define cons-level (guarded-cons empty-level))
|
||||
|
||||
;; Metalevel (Listof Metalevel) -> (Listof Metalevel).
|
||||
;; Only adds to its second argument if its first is nonempty.
|
||||
(define cons-metalevel (guarded-cons empty-metalevel))
|
||||
|
||||
;; Gestalt Nat -> Metalevel
|
||||
(define (gestalt-metalevel-ref g n)
|
||||
(safe-list-ref (gestalt-metalevels g) n (lambda () empty-metalevel)))
|
||||
|
||||
;; Gestalt × Value × Natural × Boolean → (Setof PID)
|
||||
;; Retrieves those PIDs that have active subscriptions/advertisements
|
||||
;; covering the given message at the given metalevel.
|
||||
(define (gestalt-match-value g body metalevel is-feedback?)
|
||||
(define extract-matcher (if is-feedback? cdr car)) ;; feedback targets advertisers/publishers
|
||||
(define (pids-at level) (matcher-match-value (extract-matcher level) body))
|
||||
(foldr tset-union (datum-tset) (map pids-at (gestalt-metalevel-ref g metalevel))))
|
||||
|
||||
;; project-subs : Projection [#:meta-level Nat] [#:level Nat] -> GestaltProjection
|
||||
;; project-pubs : Projection [#:meta-level Nat] [#:level Nat] -> GestaltProjection
|
||||
;;
|
||||
;; Construct projectors representing subscriptions/advertisements
|
||||
;; matching the given pattern, at the given meta-level and level.
|
||||
;; Used with gestalt-project.
|
||||
(define (project-subs p #:meta-level [ml 0] #:level [l 0])
|
||||
(projection ml l #f p (compile-projection p)))
|
||||
(define (project-pubs p #:meta-level [ml 0] #:level [l 0])
|
||||
(projection ml l #t p (compile-projection p)))
|
||||
|
||||
;; GestaltProjection -> Gestalt
|
||||
;; Converts a projection to an atomic unit of gestalt that will detect
|
||||
;; things extractable by the projection.
|
||||
(define (projection->gestalt pr)
|
||||
(simple-gestalt (not (projection-get-advertisements? pr))
|
||||
(projection->pattern (projection-spec pr))
|
||||
(+ (projection-level pr) 1)
|
||||
(projection-metalevel pr)))
|
||||
|
||||
;; Gestalt × Nat × Nat × Boolean × CompiledProjection → Matcher
|
||||
;; Retrieves the Matcher within g projected by the arguments.
|
||||
(define (gestalt-project* g metalevel level get-advertisements? capture-spec)
|
||||
(define extract-matcher (if get-advertisements? cdr car))
|
||||
(define l (safe-list-ref (gestalt-metalevel-ref g metalevel) level (lambda () empty-level)))
|
||||
(matcher-project (extract-matcher l) capture-spec))
|
||||
|
||||
;; Gestalt × GestaltProjection → Matcher
|
||||
;; Retrieves the Matcher within g projected by pr.
|
||||
(define (gestalt-project g pr)
|
||||
(match-define (projection metalevel level get-advertisements? _ capture-spec) pr)
|
||||
(gestalt-project* g metalevel level get-advertisements? capture-spec))
|
||||
|
||||
;; Gestalt × GestaltProjection → (Option (Setof (Listof Value)))
|
||||
;; Projects g with pr and calls matcher-key-set on the result.
|
||||
(define (gestalt-project/keys g pr)
|
||||
(check-projection-result g pr (matcher-key-set (gestalt-project g pr))))
|
||||
|
||||
;; Gestalt × GestaltProjection → (Option (Setof Value))
|
||||
;; Projects g with pr and calls matcher-key-set/single on the result.
|
||||
(define (gestalt-project/single g pr)
|
||||
(check-projection-result g pr (matcher-key-set/single (gestalt-project g pr))))
|
||||
|
||||
;; Gestalt × GestaltProjection × (Option A) → (Option A)
|
||||
(define (check-projection-result g pr result)
|
||||
(when (not result)
|
||||
(match-define (projection metalevel level get-advertisements? spec _) pr)
|
||||
(log-warning "Wildcard detected projecting ~a at metalevel ~a, level ~a\nwith pattern ~v from gestalt:\n~a"
|
||||
(if get-advertisements? "advs" "subs")
|
||||
metalevel
|
||||
level
|
||||
spec
|
||||
(gestalt->pretty-string g)))
|
||||
result)
|
||||
|
||||
;; Gestalt -> Gestalt
|
||||
;; Discards the 0th metalevel, renumbering others appropriately.
|
||||
;; Used to map a Gestalt from a World to Gestalts of its containing World.
|
||||
(define (drop-gestalt g)
|
||||
(gestalt (safe-cdr (gestalt-metalevels g))))
|
||||
|
||||
;; Gestalt -> Gestalt
|
||||
;; Adds a fresh empty 0th metalevel, renumbering others appropriately.
|
||||
;; Used to map Gestalt from a World's container to the World's own Gestalt.
|
||||
(define (lift-gestalt g)
|
||||
(gestalt (cons-metalevel empty-metalevel (gestalt-metalevels g))))
|
||||
|
||||
;; Nat X (Listof X) -> (Listof X)
|
||||
;; Prepends n references to x to xs.
|
||||
(define (prepend n x xs)
|
||||
(if (zero? n)
|
||||
xs
|
||||
(cons x (prepend (- n 1) x xs))))
|
||||
|
||||
;; Boolean Pattern Nat Nat -> Gestalt
|
||||
;; Compiles p and embeds it at the appropriate level and metalevel
|
||||
;; within a Gestalt. Used by (pub) and (sub) to construct "atomic"
|
||||
;; Gestalts.
|
||||
(define (simple-gestalt is-adv? p level metalevel)
|
||||
(define m (pattern->matcher #t p))
|
||||
(define pom (if is-adv? (cons #f m) (cons m #f)))
|
||||
(gestalt (prepend metalevel empty-metalevel (list (prepend level empty-level (list pom))))))
|
||||
|
||||
;; -> Gestalt
|
||||
;; The empty gestalt.
|
||||
(define (gestalt-empty) (gestalt '()))
|
||||
|
||||
;; Gestalt -> Boolean
|
||||
;; True iff the gestalt matches no messages.
|
||||
;; TODO: our invariants should ensure that (gestalt-empty? g) iff (equal? g (gestalt '())).
|
||||
;; Make sure this actually is true.
|
||||
(define (gestalt-empty? g)
|
||||
(for*/and [(ml (in-list (gestalt-metalevels g))) (l (in-list ml))]
|
||||
(and (matcher-empty? (car l)) (matcher-empty? (cdr l)))))
|
||||
|
||||
;; Nat Nat -> GestaltSet
|
||||
;; Produces a "full" gestalt including the wildcard matcher at each of
|
||||
;; the n metalevels and m levels.
|
||||
(define (gestalt-full n m)
|
||||
(define w (pattern->matcher #t ?))
|
||||
(gestalt (make-list n (make-list m (cons w w)))))
|
||||
|
||||
;; map-zip: ((U 'right-longer 'left-longer) (Listof X) -> (Listof Y))
|
||||
;; (X X -> Y)
|
||||
;; (Y (Listof Y) -> (Listof Y))
|
||||
;; (Listof X)
|
||||
;; (Listof X)
|
||||
;; -> (Listof Y)
|
||||
;; Horrific map-like function that isn't quite as picky as map about
|
||||
;; ragged input lists. The imbalance-handler is used to handle ragged
|
||||
;; inputs.
|
||||
(define (map-zip imbalance-handler item-handler gcons ls1 ls2)
|
||||
(let walk ((ls1 ls1) (ls2 ls2))
|
||||
(match* (ls1 ls2)
|
||||
[('() '()) '()]
|
||||
[('() ls) (imbalance-handler 'right-longer ls)]
|
||||
[(ls '()) (imbalance-handler 'left-longer ls)]
|
||||
[((cons l1 ls1) (cons l2 ls2))
|
||||
(gcons (item-handler l1 l2) (walk ls1 ls2))])))
|
||||
|
||||
;; Gestalt Gestalt (...->...) (Level Level -> Level) -> Gestalt
|
||||
;; Combine two gestalts with the given level-combiner.
|
||||
;; The type of imbalance-handler is awkward because of the punning.
|
||||
(define (gestalt-combine g1 g2 imbalance-handler level-combiner)
|
||||
(gestalt (map-zip imbalance-handler
|
||||
(lambda (ls1 ls2)
|
||||
(map-zip imbalance-handler level-combiner cons-level ls1 ls2))
|
||||
cons-metalevel
|
||||
(gestalt-metalevels g1)
|
||||
(gestalt-metalevels g2))))
|
||||
|
||||
;; Gestalt Gestalt (...->...) (Matcher Matcher -> Matcher) -> Gestalt
|
||||
;; Combines g1 and g2, giving subs/subs and advs/advs from g1 and g2
|
||||
;; to the matcher-combiner.
|
||||
(define (gestalt-combine-straight g1 g2 imbalance-handler matcher-combiner)
|
||||
(gestalt-combine g1 g2
|
||||
imbalance-handler
|
||||
(lambda (sa1 sa2)
|
||||
(cons (matcher-combiner (car sa1) (car sa2))
|
||||
(matcher-combiner (cdr sa1) (cdr sa2))))))
|
||||
|
||||
;; (Listof Gestalt) -> Gestalt
|
||||
;; Computes the union of the given gestalts.
|
||||
(define (gestalt-union* gs)
|
||||
(if (null? gs)
|
||||
(gestalt-empty)
|
||||
(let walk ((gs gs))
|
||||
(match gs
|
||||
[(list g) g]
|
||||
[(cons g rest) (gestalt-union1 g (walk rest))]))))
|
||||
|
||||
;; Gestalt* -> Gestalt
|
||||
;; Computes the union of its arguments.
|
||||
(define (gestalt-union . gs)
|
||||
(gestalt-union* gs))
|
||||
|
||||
;; Gestalt Gestalt -> Gestalt
|
||||
;; Computes the union of its arguments.
|
||||
(define (gestalt-union1 g1 g2) (gestalt-combine-straight g1 g2 (lambda (side x) x) matcher-union))
|
||||
|
||||
;; TODO: abstract out the folding skeletons of gestalt-filter and gestalt-match.
|
||||
|
||||
;; Gestalt Gestalt -> Gestalt
|
||||
;; View on g1 from g2's perspective.
|
||||
;; Implements the "(p)_n || <p>_m if n < m" part of NC.
|
||||
(define gestalt-filter
|
||||
(let ()
|
||||
(define (filter-metalevels mls1 mls2)
|
||||
(match* (mls1 mls2)
|
||||
[('() _) '()]
|
||||
[(_ '()) '()]
|
||||
[((cons ls1 mrest1) (cons ls2-unshifted mrest2))
|
||||
(cons-metalevel (filter-levels ls1 (safe-cdr ls2-unshifted))
|
||||
(filter-metalevels mrest1 mrest2))]))
|
||||
|
||||
(define (filter-levels ls1 ls2)
|
||||
(match ls1
|
||||
['() '()]
|
||||
[(cons (cons subs1 advs1) lrest1)
|
||||
(if (null? ls2)
|
||||
'()
|
||||
(cons-level (filter-single-level subs1 advs1 ls2)
|
||||
(filter-levels lrest1 (cdr ls2))))]))
|
||||
|
||||
(define (filter-single-level subs1 advs1 ls2)
|
||||
(let loop ((ls2 ls2) (subs #f) (advs #f))
|
||||
(match ls2
|
||||
['() (cons subs advs)]
|
||||
[(cons (cons subs2 advs2) lrest2)
|
||||
(loop lrest2
|
||||
(matcher-union subs (matcher-intersect subs1 advs2))
|
||||
(matcher-union advs (matcher-intersect advs1 subs2)))])))
|
||||
|
||||
(lambda (g1 g2)
|
||||
(parameterize ((matcher-intersect-successes (lambda (v1 v2) v1)))
|
||||
(gestalt (filter-metalevels (gestalt-metalevels g1) (gestalt-metalevels g2)))))))
|
||||
|
||||
;; Gestalt Gestalt -> (Setof PID)
|
||||
;; Much like gestalt-filter, takes a view on gestalt g1 from g2's
|
||||
;; perspective. However, instead of returning the filtered g1, returns
|
||||
;; just the set of values in the g2-map that were overlapped by some
|
||||
;; part of g1.
|
||||
(define gestalt-match
|
||||
(let ()
|
||||
(define (match-metalevels mls1 mls2 acc)
|
||||
(match* (mls1 mls2)
|
||||
[('() _) acc]
|
||||
[(_ '()) acc]
|
||||
[((cons ls1 mrest1) (cons ls2-unshifted mrest2))
|
||||
(match-levels ls1 (safe-cdr ls2-unshifted) (match-metalevels mrest1 mrest2 acc))]))
|
||||
|
||||
(define (match-levels ls1 ls2 acc)
|
||||
(match ls1
|
||||
['() acc]
|
||||
[(cons (cons subs1 advs1) lrest1)
|
||||
(if (null? ls2)
|
||||
acc
|
||||
(match-single-level subs1 advs1 ls2 (match-levels lrest1 (cdr ls2) acc)))]))
|
||||
|
||||
(define (match-single-level subs1 advs1 ls2 acc)
|
||||
(let loop ((ls2 ls2) (acc acc))
|
||||
(match ls2
|
||||
['() acc]
|
||||
[(cons (cons subs2 advs2) lrest2)
|
||||
(loop lrest2 (tset-union (tset-union (matcher-match-matcher subs1 advs2)
|
||||
(matcher-match-matcher advs1 subs2))
|
||||
acc))])))
|
||||
|
||||
(lambda (g1 g2)
|
||||
(parameterize ((matcher-match-matcher-successes (lambda (v1 v2 acc) (tset-union v2 acc)))
|
||||
(matcher-match-matcher-unit (datum-tset)))
|
||||
(match-metalevels (gestalt-metalevels g1) (gestalt-metalevels g2) (datum-tset))))))
|
||||
|
||||
;; Gestalt Gestalt -> Gestalt
|
||||
;; Erases the g2-subset of g1 from g1, yielding the result.
|
||||
(define (gestalt-subtract g1 g2)
|
||||
(gestalt-combine-straight g1 g2
|
||||
erase-imbalance-handler
|
||||
matcher-subtract))
|
||||
|
||||
;; (U 'right-longer 'left-longer) (Listof X) -> (Listof X)
|
||||
;; Asymmetric imbalance handler suitable for use in subtraction operations.
|
||||
(define (erase-imbalance-handler side x)
|
||||
(case side
|
||||
[(left-longer) x]
|
||||
[(right-longer) '()]))
|
||||
|
||||
;; Gestalt (Nat Nat Level -> Level) -> Gestalt
|
||||
;; Maps f over all levels in g, passing f the metalevel number, the
|
||||
;; level number, and the level itself, in that order.
|
||||
(define (gestalt-transform g f)
|
||||
(gestalt (let loop-outer ((mls (gestalt-metalevels g)) (i 0))
|
||||
(cond [(null? mls) '()]
|
||||
[else (cons-metalevel
|
||||
(let loop-inner ((ls (car mls)) (j 0))
|
||||
(cond [(null? ls) '()]
|
||||
[else (cons-level (f i j (car ls))
|
||||
(loop-inner (cdr ls) (+ j 1)))]))
|
||||
(loop-outer (cdr mls) (+ i 1)))]))))
|
||||
|
||||
;; Gestalt (Matcher -> Matcher) -> Gestalt
|
||||
;; Maps f over all matchers in g.
|
||||
(define (gestalt-matcher-transform g f)
|
||||
(gestalt-transform g (lambda (i j p) (cons (f (car p)) (f (cdr p))))))
|
||||
|
||||
;; Gestalt -> GestaltSet
|
||||
;; Blurs the distinctions between mapped-to processes in g.
|
||||
(define (strip-gestalt-label g)
|
||||
(gestalt-matcher-transform g (lambda (m) (matcher-relabel m (lambda (v) #t)))))
|
||||
|
||||
;; GestaltSet -> Gestalt
|
||||
;; Relabels g so that all matched keys map to (set pid).
|
||||
(define (label-gestalt g pid)
|
||||
(define pidset (datum-tset pid))
|
||||
(gestalt-matcher-transform g (lambda (m) (matcher-relabel m (lambda (v) pidset)))))
|
||||
|
||||
;; Gestalt Nat -> Nat
|
||||
;; Returns the number of "interesting" levels in g at metalevel n.
|
||||
(define (gestalt-level-count g n)
|
||||
(length (gestalt-metalevel-ref g n)))
|
||||
|
||||
;; Gestalt [OutputPort] -> Void
|
||||
;; Pretty-prints g on port.
|
||||
(define (pretty-print-gestalt g [port (current-output-port)])
|
||||
(if (gestalt-empty? g)
|
||||
(fprintf port "EMPTY GESTALT\n")
|
||||
(for [(metalevel (in-naturals)) (ls (in-list (gestalt-metalevels g)))]
|
||||
(for [(level (in-naturals)) (p (in-list ls))]
|
||||
(match-define (cons subs advs) p)
|
||||
(when (or subs advs)
|
||||
(fprintf port "GESTALT metalevel ~v level ~v:\n" metalevel level)
|
||||
(when subs (fprintf port " - subs:") (pretty-print-matcher subs port #:indent 9))
|
||||
(when advs (fprintf port " - advs:") (pretty-print-matcher advs port #:indent 9)))))))
|
||||
|
||||
;; Gestalt -> String
|
||||
;; Returns a string containing the pretty-printing of g.
|
||||
(define (gestalt->pretty-string g)
|
||||
(with-output-to-string (lambda () (pretty-print-gestalt g))))
|
||||
|
||||
;; Gestalt [(Value -> JSExpr)] -> JSExpr
|
||||
;; Serializes a gestalt to a JSON expression.
|
||||
(define (gestalt->jsexpr g [success->jsexpr (lambda (v) #t)])
|
||||
(list "gestalt" (for/list [(ls (in-list (gestalt-metalevels g)))]
|
||||
(for/list [(l (in-list ls))]
|
||||
(match-define (cons subs advs) l)
|
||||
(list (matcher->jsexpr subs success->jsexpr)
|
||||
(matcher->jsexpr advs success->jsexpr))))))
|
||||
|
||||
;; JSExpr [(JSExpr -> Value)] -> Gestalt
|
||||
;; Deserializes a gestalt from a JSON expression.
|
||||
(define (jsexpr->gestalt j [jsexpr->success (lambda (v) #t)])
|
||||
(match j
|
||||
[(list "gestalt" mlsj)
|
||||
(gestalt (for/list [(lsj (in-list mlsj))]
|
||||
(for/list [(lj (in-list lsj))]
|
||||
(match-define (list sj aj) lj)
|
||||
(cons (jsexpr->matcher sj jsexpr->success)
|
||||
(jsexpr->matcher aj jsexpr->success)))))]))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
|
||||
(check-equal? (simple-gestalt #f 'a 0 0)
|
||||
(gestalt (list (list (cons (pattern->matcher #t 'a) #f)))))
|
||||
(check-equal? (simple-gestalt #t 'b 0 0)
|
||||
(gestalt (list (list (cons #f (pattern->matcher #t 'b))))))
|
||||
(check-equal? (simple-gestalt #f 'a 2 2)
|
||||
(gestalt (list empty-metalevel empty-metalevel
|
||||
(list empty-level empty-level
|
||||
(cons (pattern->matcher #t 'a) #f)))))
|
||||
(check-equal? (simple-gestalt #t 'b 2 2)
|
||||
(gestalt (list empty-metalevel empty-metalevel
|
||||
(list empty-level empty-level
|
||||
(cons #f (pattern->matcher #t 'b))))))
|
||||
|
||||
(check-equal? (gestalt-union (simple-gestalt #f 'a 0 0)
|
||||
(simple-gestalt #t 'b 0 0))
|
||||
(gestalt (list (list (cons (pattern->matcher #t 'a)
|
||||
(pattern->matcher #t 'b))))))
|
||||
(check-equal? (gestalt-union (simple-gestalt #f 'a 2 2)
|
||||
(simple-gestalt #t 'b 2 2))
|
||||
(gestalt (list empty-metalevel empty-metalevel
|
||||
(list empty-level empty-level
|
||||
(cons (pattern->matcher #t 'a)
|
||||
(pattern->matcher #t 'b))))))
|
||||
|
||||
(require json)
|
||||
(let ((J (string->jsexpr "[\"gestalt\",[[[[[\"A\",[[[\")\"],[\"\",true]]]]],[]]],[],[[[],[]],[[],[]],[[],[[\"B\",[[[\")\"],[\"\",true]]]]]]]]]"))
|
||||
(G (gestalt-union (simple-gestalt #f "A" 0 0) (simple-gestalt #t "B" 2 2))))
|
||||
(check-equal? (jsexpr->gestalt J (lambda (v) v)) G)
|
||||
(check-equal? (gestalt->jsexpr G (lambda (v) v)) J)))
|
||||
|
|
@ -1,94 +1,54 @@
|
|||
#lang racket/base
|
||||
;; Breaking the infinite tower of nested Worlds, connecting to the "real" world at the fracture line.
|
||||
|
||||
(require racket/async-channel)
|
||||
(require racket/set)
|
||||
(require racket/match)
|
||||
(require racket/list)
|
||||
(require "core.rkt")
|
||||
(require "gestalt.rkt")
|
||||
(require "trace/stderr.rkt")
|
||||
|
||||
(provide (struct-out event)
|
||||
send-ground-message
|
||||
run-ground)
|
||||
|
||||
;; A GroundEvent is a pair of a Racket (evt?) event and its yielded
|
||||
;; results.
|
||||
;; - (event RacketEvent (Listof Any))
|
||||
(struct event (descriptor values) #:prefab)
|
||||
|
||||
;; (Parameterof (Option AsyncChannel))
|
||||
;; Communication channel from auxiliary (usually driver) threads to
|
||||
;; the currently-active ground VM.
|
||||
(define current-ground-event-async-channel (make-parameter (make-async-channel)))
|
||||
|
||||
;; Any -> Void
|
||||
;; Sends a (non-feedback) message at the ground-VM metalevel.
|
||||
(define (send-ground-message body)
|
||||
(async-channel-put (current-ground-event-async-channel) (send body)))
|
||||
|
||||
;; RacketEvent -> RacketEvent
|
||||
;; Wraps a CML-style Racket event with a handler that sends the event
|
||||
;; results via the ground VM.
|
||||
(define (event-handler descriptor)
|
||||
(handle-evt descriptor (lambda vs (send (event descriptor vs)))))
|
||||
|
||||
;; GestaltProjection
|
||||
;; Used to extract event descriptors and results from subscriptions
|
||||
;; from the ground VM's contained World.
|
||||
(define event-projection (project-subs (event (?!) ?)))
|
||||
(define (extract-active-events routes)
|
||||
(filter-map (lambda (r)
|
||||
(and (route-subscription? r)
|
||||
(zero? (route-meta-level r))
|
||||
(zero? (route-level r))
|
||||
(match (route-pattern r)
|
||||
[(event descriptor (? wildcard?)) (event-handler descriptor)]
|
||||
[_ #f])))
|
||||
routes))
|
||||
|
||||
;; Gestalt -> (Listof RacketEvent)
|
||||
;; Projects out the active event subscriptions from the given gestalt.
|
||||
(define (extract-active-events gestalt)
|
||||
(define es (gestalt-project/single gestalt event-projection))
|
||||
;; TODO: how should the following error be handled, ideally?
|
||||
;; In principle, security restrictions should make it impossible.
|
||||
;; But absent those, what should be done? Should an offending
|
||||
;; process be identified and terminated?
|
||||
(unless es (error 'extract-active-events "User program subscribed to wildcard event"))
|
||||
(for/list [(e (in-set es))] (event-handler e)))
|
||||
|
||||
;; RacketEvent
|
||||
;; Used only when the system is not provably inert, in order to let it
|
||||
;; take further internal reductions.
|
||||
(define idle-handler
|
||||
(handle-evt (system-idle-evt) (lambda _ #f)))
|
||||
|
||||
;; Action* -> Void
|
||||
;; Runs a ground VM, booting the outermost World with the given Actions.
|
||||
(define (run-ground . boot-actions)
|
||||
(let await-interrupt ((inert? #f)
|
||||
(p (spawn-process (spawn-world boot-actions))) ;; we are guaranteed boot-proc is ignorable here
|
||||
(active-events '()))
|
||||
(define active-gestalt (process-gestalt p))
|
||||
(let await-interrupt ((inert? #f) (p (spawn-world boot-actions)) (active-events '()))
|
||||
(define event-list (if inert?
|
||||
active-events
|
||||
(cons idle-handler active-events)))
|
||||
(if (and (null? event-list) (gestalt-empty? active-gestalt))
|
||||
(if (null? event-list)
|
||||
(begin (log-info "run-ground: Terminating because inert")
|
||||
(void))
|
||||
(let ((e (apply sync (current-ground-event-async-channel) event-list)))
|
||||
(let ((e (apply sync event-list)))
|
||||
(match (deliver-event e -2 p)
|
||||
[#f ;; inert
|
||||
(await-interrupt #t p active-events)]
|
||||
[(transition new-state actions)
|
||||
(let process-actions ((actions (flatten actions)) (g active-gestalt))
|
||||
(let process-actions ((actions (flatten actions)) (active-events active-events))
|
||||
(match actions
|
||||
['()
|
||||
(await-interrupt #f
|
||||
(struct-copy process p
|
||||
[gestalt g]
|
||||
[state new-state])
|
||||
(extract-active-events g))]
|
||||
(await-interrupt #f (struct-copy process p [state new-state]) active-events)]
|
||||
[(cons a actions)
|
||||
(match a
|
||||
[(routing-update gestalt)
|
||||
(process-actions actions gestalt)]
|
||||
[(routing-update routes)
|
||||
(process-actions actions (extract-active-events routes))]
|
||||
[(quit)
|
||||
(log-info "run-ground: Terminating by request")
|
||||
(void)]
|
||||
[_
|
||||
(log-warning "run-ground: ignoring useless meta-action ~v" a)
|
||||
(process-actions actions g)])]))])))))
|
||||
(process-actions actions active-events)])]))])))))
|
||||
|
|
|
|||
|
|
@ -1,12 +1,8 @@
|
|||
#lang racket/base
|
||||
|
||||
(require "core.rkt")
|
||||
(require "gestalt.rkt")
|
||||
(require "ground.rkt")
|
||||
(require "actor.rkt")
|
||||
|
||||
(provide (all-from-out "core.rkt")
|
||||
(all-from-out "gestalt.rkt")
|
||||
(all-from-out "ground.rkt")
|
||||
(all-from-out "actor.rkt"))
|
||||
(all-from-out "ground.rkt"))
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,122 @@
|
|||
#lang racket/base
|
||||
|
||||
(require racket/set)
|
||||
(require racket/match)
|
||||
(require (only-in racket/class object?))
|
||||
|
||||
(provide ?
|
||||
wildcard?
|
||||
specialization?
|
||||
ground?
|
||||
intersect
|
||||
intersect?
|
||||
pattern-subst)
|
||||
|
||||
(struct exn:unification-failure ())
|
||||
(define unification-failure (exn:unification-failure))
|
||||
(define (fail) (raise unification-failure))
|
||||
|
||||
(struct wildcard ()
|
||||
#:transparent
|
||||
#:property prop:custom-write
|
||||
(lambda (v port mode)
|
||||
(display "?" port)))
|
||||
|
||||
(define ? (wildcard))
|
||||
|
||||
;; Any -> Boolean
|
||||
;; Racket objects are structures, so we reject them explicitly for
|
||||
;; now, leaving them opaque to unification.
|
||||
(define (non-object-struct? x)
|
||||
(and (struct? x)
|
||||
(not (object? x))))
|
||||
|
||||
;; True iff a is a specialization (or instance) of b.
|
||||
(define (specialization? a b)
|
||||
(let walk ((a a) (b b))
|
||||
(cond
|
||||
[(wildcard? b) #t]
|
||||
[(wildcard? a) #f]
|
||||
[(and (pair? a) (pair? b))
|
||||
(and (walk (car a) (car b)) (walk (cdr a) (cdr b)))]
|
||||
[(and (vector? a) (vector? b) (= (vector-length a) (vector-length b)))
|
||||
(for/and ([aa a] [bb b]) (walk aa bb))]
|
||||
[(and (non-object-struct? a) (non-object-struct? b))
|
||||
(walk (struct->vector a #f) (struct->vector b #f))]
|
||||
[(and (hash? a) (hash? b))
|
||||
(for/and ([k (in-hash-keys b)])
|
||||
(and (hash-has-key? a k)
|
||||
(walk (hash-ref a k) (hash-ref b k))))]
|
||||
[else (equal? a b)])))
|
||||
|
||||
;; Any -> Boolean
|
||||
;; True iff the term is completely ground, that is has no variables or
|
||||
;; canonical-variables in it.
|
||||
(define (ground? x)
|
||||
(let walk ((x x))
|
||||
(cond
|
||||
[(wildcard? x) #f]
|
||||
[(pair? x) (and (walk (car x)) (walk (cdr x)))]
|
||||
[(vector? x) (andmap walk (vector->list x))]
|
||||
[(non-object-struct? x) (walk (struct->vector x #f))]
|
||||
[(hash? x) (for/and ([v (in-hash-values x)]) (walk v))]
|
||||
[else #t])))
|
||||
|
||||
;; Vector StructType -> Struct
|
||||
(define (vector->struct v t)
|
||||
(apply (struct-type-make-constructor t) (cdr (vector->list v))))
|
||||
|
||||
;; Any Any -> Any
|
||||
(define (unify a b)
|
||||
(cond
|
||||
[(wildcard? a) b]
|
||||
[(wildcard? b) a]
|
||||
[(and (pair? a) (pair? b))
|
||||
(cons (unify (car a) (car b)) (unify (cdr a) (cdr b)))]
|
||||
[(and (vector? a) (vector? b))
|
||||
(unless (= (vector-length a) (vector-length b)) (fail))
|
||||
(for/vector ((va (in-vector a)) (vb (in-vector b))) (unify va vb))]
|
||||
[(and (non-object-struct? a) (non-object-struct? b))
|
||||
(define-values (ta ta-skipped?) (struct-info a))
|
||||
(define-values (tb tb-skipped?) (struct-info b))
|
||||
(unless (eq? ta tb) (fail))
|
||||
(when ta-skipped? (fail))
|
||||
(when tb-skipped? (fail))
|
||||
(vector->struct (unify (struct->vector a) (struct->vector b)) ta)]
|
||||
[(and (hash? a) (hash? b))
|
||||
(for/hash ([k (in-set (set-union (list->set (hash-keys a)) (list->set (hash-keys b))))])
|
||||
(when (not (hash-has-key? a k)) (fail))
|
||||
(when (not (hash-has-key? b k)) (fail))
|
||||
(values k (unify (hash-ref a k) (hash-ref b k))))]
|
||||
[(equal? a b)
|
||||
a]
|
||||
[else (fail)]))
|
||||
|
||||
;; Any Any (Any -> X) (-> X) -> X
|
||||
(define (intersect a b ks kf)
|
||||
(define-values (ok? result)
|
||||
(with-handlers ([exn:unification-failure? (lambda (e) (values #f (void)))])
|
||||
(values #t (unify a b))))
|
||||
(if ok?
|
||||
(ks result)
|
||||
(kf)))
|
||||
|
||||
;; Any Any -> Boolean
|
||||
(define (intersect? a b)
|
||||
(with-handlers ([exn:unification-failure? (lambda (e) #f)])
|
||||
(unify a b)
|
||||
#t))
|
||||
|
||||
(define (pattern-subst x from to)
|
||||
(let walk ((x x))
|
||||
(cond
|
||||
[(equal? x from) to]
|
||||
[(pair? x) (cons (walk (car x)) (walk (cdr x)))]
|
||||
[(vector? x) (for/vector ([e (in-vector x)]) (walk e))]
|
||||
[(non-object-struct? x)
|
||||
(define-values (tx tx-skipped?) (struct-info x))
|
||||
(when tx-skipped?
|
||||
(error 'pattern-subst "Cannot substitute in (partially-)opaque structs: ~v" x))
|
||||
(vector->struct (walk (struct->vector x #f)) tx)]
|
||||
[(hash? x) (for/hash ([(k v) (in-hash x)]) (values k (walk v)))]
|
||||
[else x])))
|
||||
|
|
@ -0,0 +1,25 @@
|
|||
#lang racket/base
|
||||
|
||||
(require racket/set)
|
||||
(require racket/match)
|
||||
(require "core.rkt")
|
||||
|
||||
(provide (except-out (struct-out presence-detector) presence-detector)
|
||||
(rename-out [make-presence-detector presence-detector])
|
||||
presence-detector-update
|
||||
presence-detector-routes)
|
||||
|
||||
(struct presence-detector (route-set) #:transparent)
|
||||
|
||||
(define (make-presence-detector [initial-routes '()])
|
||||
(presence-detector (list->set initial-routes)))
|
||||
|
||||
(define (presence-detector-update p rs)
|
||||
(define old-route-set (presence-detector-route-set p))
|
||||
(define new-route-set (list->set rs))
|
||||
(values (struct-copy presence-detector p [route-set new-route-set])
|
||||
(set-subtract new-route-set old-route-set)
|
||||
(set-subtract old-route-set new-route-set)))
|
||||
|
||||
(define (presence-detector-routes p)
|
||||
(set->list (presence-detector-route-set p)))
|
||||
1668
minimart/route.rkt
1668
minimart/route.rkt
File diff suppressed because it is too large
Load Diff
|
|
@ -1,40 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide trace-logger
|
||||
|
||||
trace-pid-stack
|
||||
call-in-trace-context
|
||||
|
||||
trace-process-step
|
||||
trace-internal-step)
|
||||
|
||||
(require "exn-util.rkt")
|
||||
|
||||
(define trace-logger (make-logger 'minimart-trace))
|
||||
|
||||
;; (Parameterof (Listof PID))
|
||||
;; Path to the active leaf in the process tree. The car end is the
|
||||
;; leaf; the cdr end, the root. Used for debugging and tracing purposes.
|
||||
(define trace-pid-stack (make-parameter '()))
|
||||
|
||||
;; PID (-> Any) -> Any
|
||||
;; Pushes pid on trace-pid-stack for the duration of the call to thunk.
|
||||
(define (call-in-trace-context pid thunk)
|
||||
(parameterize ((trace-pid-stack (cons pid (trace-pid-stack))))
|
||||
(thunk)))
|
||||
|
||||
(define-syntax-rule (record-trace-event name r)
|
||||
(when (log-level? trace-logger 'info)
|
||||
(log-message trace-logger 'info name "" r #f)))
|
||||
|
||||
;; Event PID Process (Option Exception) (Option Transition) -> Void
|
||||
(define (trace-process-step e pid p exn t)
|
||||
(when exn
|
||||
(log-error "Process ~a died with exception:\n~a"
|
||||
(cons pid (trace-pid-stack))
|
||||
(exn->string exn)))
|
||||
(record-trace-event 'process-step (list (cons pid (trace-pid-stack)) e p exn t)))
|
||||
|
||||
;; PID Action World Transition -> Void
|
||||
(define (trace-internal-step pid a w t)
|
||||
(record-trace-event 'internal-step (list (cons pid (trace-pid-stack)) a w t)))
|
||||
|
|
@ -1,205 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide set-stderr-trace-flags!)
|
||||
|
||||
(require racket/set)
|
||||
(require racket/match)
|
||||
(require racket/pretty)
|
||||
(require (only-in racket/string string-join))
|
||||
(require "../core.rkt")
|
||||
(require "../gestalt.rkt")
|
||||
(require "../trace.rkt")
|
||||
(require "../exn-util.rkt")
|
||||
|
||||
(define (env-aref varname default alist)
|
||||
(define key (or (getenv varname) default))
|
||||
(cond [(assoc key alist) => cadr]
|
||||
[else (error 'env-aref
|
||||
"Expected environment variable ~a to contain one of ~v; got ~v"
|
||||
(map car alist)
|
||||
key)]))
|
||||
|
||||
(define colored-output? (env-aref "MINIMART_COLOR" "true" '(("true" #t) ("false" #f))))
|
||||
|
||||
(define flags (set))
|
||||
(define show-exceptions? #f)
|
||||
(define show-routing-update-events? #f)
|
||||
(define show-message-events? #f)
|
||||
(define show-events? #f)
|
||||
(define show-process-states-pre? #f)
|
||||
(define show-process-states-post? #f)
|
||||
(define show-process-lifecycle? #f)
|
||||
(define show-routing-update-actions? #f)
|
||||
(define show-message-actions? #f)
|
||||
(define show-actions? #f)
|
||||
(define show-world-gestalt? #f)
|
||||
|
||||
(define (set-stderr-trace-flags! flags-string)
|
||||
(set! flags (for/set [(c flags-string)] (string->symbol (string c))))
|
||||
(set! show-exceptions? (set-member? flags 'x))
|
||||
(set! show-routing-update-events? (set-member? flags 'r))
|
||||
(set! show-message-events? (set-member? flags 'm))
|
||||
(set! show-events? (set-member? flags 'e))
|
||||
(set! show-process-states-pre? (set-member? flags 's))
|
||||
(set! show-process-states-post? (set-member? flags 't))
|
||||
(set! show-process-lifecycle? (set-member? flags 'p))
|
||||
(set! show-routing-update-actions? (set-member? flags 'R))
|
||||
(set! show-message-actions? (set-member? flags 'M))
|
||||
(set! show-actions? (set-member? flags 'a))
|
||||
(set! show-world-gestalt? (set-member? flags 'g)))
|
||||
|
||||
(set-stderr-trace-flags! (or (getenv "MINIMART_TRACE") ""))
|
||||
|
||||
(define YELLOW-ON-RED ";1;33;41")
|
||||
(define WHITE-ON-RED ";1;37;41")
|
||||
(define WHITE-ON-GREEN ";1;37;42")
|
||||
(define GREY-ON-RED ";37;41")
|
||||
(define GREY-ON-GREEN ";37;42")
|
||||
(define RED ";31")
|
||||
(define BRIGHT-RED ";1;31")
|
||||
(define GREEN ";32")
|
||||
(define BRIGHT-GREEN ";1;32")
|
||||
(define YELLOW ";33")
|
||||
(define BLUE ";34")
|
||||
(define BRIGHT-BLUE ";1;34")
|
||||
(define NORMAL "")
|
||||
|
||||
;; Drops the final "-2".
|
||||
(define (format-pids pids)
|
||||
(if (equal? pids '(-2))
|
||||
"Ground"
|
||||
(string-join (map number->string (cdr (reverse pids))) ":")))
|
||||
|
||||
(define (output fmt . args)
|
||||
(apply fprintf (current-error-port) fmt args))
|
||||
|
||||
(define (output-state state)
|
||||
(cond
|
||||
[(trigger-guard? state) (output-state (trigger-guard-state state))]
|
||||
[(world? state) (output "#<world>\n")]
|
||||
[else (pretty-write state (current-error-port))]))
|
||||
|
||||
(define (boring-state? state)
|
||||
(or (world? state)
|
||||
(void? state)
|
||||
(and (trigger-guard? state)
|
||||
(boring-state? (trigger-guard-state state)))))
|
||||
|
||||
(define (set-color! c) (when colored-output? (output "\e[0~am" c)))
|
||||
(define (reset-color!) (when colored-output? (output "\e[0m")))
|
||||
|
||||
(define-syntax-rule (with-color c expr ...)
|
||||
(begin (set-color! c)
|
||||
(begin0 (begin expr ...)
|
||||
(reset-color!))))
|
||||
|
||||
(define (display-trace)
|
||||
(define receiver (make-log-receiver trace-logger 'info))
|
||||
(parameterize ((pretty-print-columns 100))
|
||||
(let loop ()
|
||||
(match-define (vector level message-string data event-name) (sync receiver))
|
||||
(match* (event-name data)
|
||||
[('process-step (list pids e p exn t))
|
||||
(define pidstr (format-pids pids))
|
||||
(define relevant-exn? (and show-exceptions? exn))
|
||||
(match e
|
||||
[#f
|
||||
(when (or relevant-exn? show-events?)
|
||||
(with-color YELLOW (output "~a was polled for changes.\n" pidstr)))]
|
||||
['#:boot
|
||||
(when (or relevant-exn? show-events?)
|
||||
(with-color YELLOW (output "~a was booted.\n" pidstr)))]
|
||||
[(routing-update g)
|
||||
(when (or relevant-exn? show-events? show-routing-update-events?)
|
||||
(with-color YELLOW
|
||||
(output "~a received a routing-update:\n" pidstr)
|
||||
(pretty-print-gestalt g (current-error-port))))]
|
||||
[(message body meta-level feedback?)
|
||||
(when (or relevant-exn? show-events? show-message-events?)
|
||||
(with-color YELLOW
|
||||
(output "~a received ~a at metalevel ~a:\n"
|
||||
pidstr
|
||||
(if feedback? "feedback" "a message")
|
||||
meta-level)
|
||||
(pretty-write body (current-error-port))))])
|
||||
(when (or relevant-exn? show-process-states-pre?)
|
||||
(when (or relevant-exn? (not (boring-state? (process-state p))))
|
||||
(with-color YELLOW
|
||||
(output "~a's state just before the event:\n" pidstr)
|
||||
(output-state (process-state p)))))
|
||||
(when relevant-exn?
|
||||
(with-color WHITE-ON-RED
|
||||
(output "Process ~a died with exception:\n~a\n"
|
||||
pidstr
|
||||
(exn->string exn))))
|
||||
(when (or relevant-exn? show-process-states-post?)
|
||||
(when t
|
||||
(unless (boring-state? (transition-state t))
|
||||
(when (not (equal? (process-state p) (transition-state t)))
|
||||
(with-color YELLOW
|
||||
(output "~a's state just after the event:\n" pidstr)
|
||||
(output-state (transition-state t)))))))]
|
||||
[('internal-step (list pids a old-w t))
|
||||
(when t ;; inert worlds don't change interestingly
|
||||
(define pidstr (format-pids pids))
|
||||
(define new-w (transition-state t))
|
||||
(define old-processes (world-process-table old-w))
|
||||
(define new-processes (world-process-table new-w))
|
||||
(define newcount (hash-count new-processes))
|
||||
(match a
|
||||
[(<spawn> _boot-proc (process gestalt behavior state))
|
||||
(when (or show-process-lifecycle? show-actions?)
|
||||
(define newpid (set-first (set-subtract (hash-keys new-processes)
|
||||
(hash-keys old-processes))))
|
||||
(define newpidstr (format-pids (cons newpid (cdr pids)))) ;; replace parent pid
|
||||
(with-color BRIGHT-GREEN
|
||||
(output "~a ~v spawned from ~a (~a total processes now)\n"
|
||||
newpidstr
|
||||
behavior
|
||||
pidstr
|
||||
newcount))
|
||||
(unless (boring-state? state)
|
||||
(output "~a's initial state:\n" newpidstr)
|
||||
(output-state state))
|
||||
(unless (gestalt-empty? gestalt)
|
||||
(output "~a's initial gestalt:\n" newpidstr)
|
||||
(pretty-print-gestalt gestalt (current-error-port))))]
|
||||
[(quit)
|
||||
(when (or show-process-lifecycle? show-actions?)
|
||||
(match (hash-ref old-processes (car pids) (lambda () #f))
|
||||
[#f (void)]
|
||||
[(process gestalt behavior state)
|
||||
(with-color BRIGHT-RED
|
||||
(output "~a ~v exited (~a total processes now)\n"
|
||||
pidstr
|
||||
(if (trigger-guard? state)
|
||||
(trigger-guard-handler state)
|
||||
behavior)
|
||||
newcount))
|
||||
(unless (boring-state? state)
|
||||
(output "~a's final state:\n" pidstr)
|
||||
(output-state state))
|
||||
(unless (gestalt-empty? gestalt)
|
||||
(output "~a's final gestalt:\n" pidstr)
|
||||
(pretty-print-gestalt gestalt (current-error-port)))]))]
|
||||
[(routing-update g)
|
||||
(when (or show-actions? show-routing-update-actions?)
|
||||
(output "~a performed a routing-update:\n" pidstr)
|
||||
(pretty-print-gestalt g (current-error-port)))]
|
||||
[(message body meta-level feedback?)
|
||||
(when (or show-actions? show-message-actions?)
|
||||
(output "~a sent ~a at metalevel ~a:\n"
|
||||
pidstr
|
||||
(if feedback? "feedback" "a message")
|
||||
meta-level)
|
||||
(pretty-write body (current-error-port)))])
|
||||
(when show-world-gestalt?
|
||||
(when (not (equal? (world-full-gestalt old-w) (world-full-gestalt new-w)))
|
||||
(with-color BRIGHT-BLUE
|
||||
(output "~a's full gestalt:\n" (format-pids (cdr pids)))
|
||||
(pretty-print-gestalt (world-full-gestalt new-w)
|
||||
(current-error-port))))))])
|
||||
(loop))))
|
||||
|
||||
(void (when (not (set-empty? flags))
|
||||
(thread display-trace)))
|
||||
|
|
@ -1,220 +0,0 @@
|
|||
#lang racket/base
|
||||
;; Treaps, which have the lovely property of *canonical representation*.
|
||||
;;
|
||||
;; We take care to preserve an additional invariant:
|
||||
;; - if n is a left child of m, then n's priority <= m's priority, and
|
||||
;; - if n is a right child of m, then n's priority < m's priority.
|
||||
;;
|
||||
;; Further, we explicitly canonicalize N instances, so eq? works to compare treaps by value.
|
||||
|
||||
(provide treap?
|
||||
treap-order
|
||||
treap-size
|
||||
treap-empty
|
||||
treap-empty?
|
||||
treap->empty
|
||||
treap-insert
|
||||
treap-delete
|
||||
treap-get
|
||||
treap-keys
|
||||
treap-values
|
||||
treap-fold
|
||||
treap-to-alist
|
||||
treap-has-key?
|
||||
|
||||
treap-height)
|
||||
|
||||
(require racket/set)
|
||||
(require racket/match)
|
||||
|
||||
(require "canonicalize.rkt")
|
||||
;; (define canonicalize values)
|
||||
|
||||
(struct N (key value priority left right) #:transparent
|
||||
#:methods gen:equal+hash
|
||||
[(define (equal-proc a b =?)
|
||||
(match-define (N ak av ap al ar) a)
|
||||
(match-define (N bk bv bp bl br) b)
|
||||
(and (eq? al bl)
|
||||
(eq? ar br)
|
||||
(= ap bp)
|
||||
(=? ak bk)
|
||||
(=? av bv)))
|
||||
(define (hash-proc a h)
|
||||
(match-define (N ak av ap al ar) a)
|
||||
(+ (eq-hash-code al)
|
||||
(eq-hash-code ar)
|
||||
(h ap)
|
||||
(h ak)
|
||||
(h av)))
|
||||
(define (hash2-proc a h)
|
||||
(match-define (N ak av ap al ar) a)
|
||||
(bitwise-xor (eq-hash-code al)
|
||||
(eq-hash-code ar)
|
||||
(h ap)
|
||||
(h ak)
|
||||
(h av)))])
|
||||
|
||||
(struct L () #:transparent)
|
||||
|
||||
(struct treap (order root size) #:transparent)
|
||||
|
||||
;; The singleton "empty" leaf sentinel
|
||||
(define L0 (L))
|
||||
|
||||
(define (treap-empty o) (treap o L0 0))
|
||||
|
||||
(define (treap-empty? t) (zero? (treap-size t)))
|
||||
|
||||
(define (treap->empty t) (treap-empty (treap-order t)))
|
||||
|
||||
(define (default-priority key)
|
||||
;; Loosely based on a restriction of murmur32 v3
|
||||
(define c1 #xcc9e2d51)
|
||||
(define c2 #x1b873593)
|
||||
(define r1 15)
|
||||
(define r2 13)
|
||||
(define m 5)
|
||||
(define n #xe6546b64)
|
||||
(define k (* (equal-hash-code key) c1))
|
||||
(define hash0 (* c2 (bitwise-ior (arithmetic-shift k r1) (arithmetic-shift k (- 32 r1)))))
|
||||
(define hash1
|
||||
(+ n (* m (bitwise-ior (arithmetic-shift hash0 r2) (arithmetic-shift hash0 (- 32 r2))))))
|
||||
(define hash2
|
||||
(bitwise-and #xffffffff (* #x85ebca6b (bitwise-xor hash1 (arithmetic-shift hash1 -16)))))
|
||||
(define hash3
|
||||
(bitwise-and #xffffffff (* #xc2b2ae35 (bitwise-xor hash2 (arithmetic-shift hash2 -13)))))
|
||||
(bitwise-xor hash3 (arithmetic-shift hash3 -16)))
|
||||
|
||||
(define (treap-insert t key value [priority (default-priority key)])
|
||||
(match-define (treap order root oldsize) t)
|
||||
(define newsize (+ oldsize 1)) ;; WARNING: mutated below!
|
||||
(define newroot
|
||||
(let walk ((n root))
|
||||
(match n
|
||||
[(L)
|
||||
(canonicalize (N key value priority L0 L0))]
|
||||
[(N k v p left right)
|
||||
(case (order key k)
|
||||
[(<) (match (walk left) [(N K V P l r) (rotate K V P k v p l r right)])]
|
||||
[(>) (match (walk right) [(N K V P l r) (rotate k v p K V P left l r)])]
|
||||
[(=)
|
||||
(set! newsize (- newsize 1)) ;; we are *REPLACING* an existing value
|
||||
(let merge ((left left) (right right))
|
||||
(cond
|
||||
[(priority>= priority left)
|
||||
(if (priority> priority right)
|
||||
(canonicalize (N key value priority left right))
|
||||
(replace-left right (merge left (N-left right))))]
|
||||
[(priority> priority right)
|
||||
(replace-right left (merge (N-right left) right))]
|
||||
[else
|
||||
(if (priority> (N-priority left) right)
|
||||
(replace-right left (merge (N-right left) right))
|
||||
(replace-left right (merge left (N-left right))))]))])])))
|
||||
(canonicalize (treap order newroot newsize)))
|
||||
|
||||
(define (replace-left n x)
|
||||
(canonicalize
|
||||
(match n
|
||||
[(N k v p _ r)
|
||||
(N k v p x r)])))
|
||||
|
||||
(define (replace-right n x)
|
||||
(canonicalize
|
||||
(match n
|
||||
[(N k v p l _)
|
||||
(N k v p l x)])))
|
||||
|
||||
(define (priority> p1 n)
|
||||
(match n
|
||||
[(L) #t]
|
||||
[(N _ _ p2 _ _) (> p1 p2)]))
|
||||
|
||||
(define (priority>= p1 n)
|
||||
(match n
|
||||
[(L) #t]
|
||||
[(N _ _ p2 _ _) (>= p1 p2)]))
|
||||
|
||||
(define (rotate k1 v1 p1 k2 v2 p2 tl tm tr)
|
||||
(if (> p1 p2)
|
||||
(canonicalize (N k1 v1 p1 tl (canonicalize (N k2 v2 p2 tm tr))))
|
||||
(canonicalize (N k2 v2 p2 (canonicalize (N k1 v1 p1 tl tm)) tr))))
|
||||
|
||||
(define (treap-delete t key)
|
||||
(match-define (treap order root oldsize) t)
|
||||
(define newsize oldsize)
|
||||
(define newroot
|
||||
(let walk ((n root))
|
||||
(match n
|
||||
[(L) L0]
|
||||
[(N k v p left right)
|
||||
(case (order key k)
|
||||
[(<) (canonicalize (N k v p (walk left) right))]
|
||||
[(>) (canonicalize (N k v p left (walk right)))]
|
||||
[(=)
|
||||
(set! newsize (- newsize 1)) ;; we found the value to remove
|
||||
(let merge ((left left) (right right))
|
||||
(cond
|
||||
[(L? left) right]
|
||||
[(L? right) left]
|
||||
[else
|
||||
(match-define (N lk lv lp ll lr) left)
|
||||
(match-define (N rk rv rp rl rr) right)
|
||||
(canonicalize
|
||||
(if (< lp rp)
|
||||
(N lk lv lp ll (merge lr right))
|
||||
(N rk rv rp (merge left rl) rr)))]))])])))
|
||||
(canonicalize (treap order newroot newsize)))
|
||||
|
||||
(define (treap-get t key [on-missing (lambda () #f)])
|
||||
(define order (treap-order t))
|
||||
(let walk ((n (treap-root t)))
|
||||
(match n
|
||||
[(L) (on-missing)]
|
||||
[(N k v _ left right)
|
||||
(case (order key k)
|
||||
[(<) (walk left)]
|
||||
[(>) (walk right)]
|
||||
[(=) v])])))
|
||||
|
||||
(define (treap-keys t #:empty-set [empty-set (set)])
|
||||
(let walk ((n (treap-root t)) (acc empty-set))
|
||||
(match n
|
||||
[(L) acc]
|
||||
[(N k _ _ left right) (walk left (walk right (set-add acc k)))])))
|
||||
|
||||
(define (treap-values t)
|
||||
(let walk ((n (treap-root t)) (acc '()))
|
||||
(match n
|
||||
[(L) acc]
|
||||
[(N k _ _ left right) (walk left (cons k (walk right acc)))])))
|
||||
|
||||
(define (treap-fold t f seed)
|
||||
(let walk ((n (treap-root t)) (acc seed))
|
||||
(match n
|
||||
[(L) acc]
|
||||
[(N k v _ left right) (walk left (f (walk right acc) k v))])))
|
||||
|
||||
(define (treap-to-alist t)
|
||||
(let walk ((n (treap-root t)) (acc '()))
|
||||
(match n
|
||||
[(L) acc]
|
||||
[(N k v _ left right) (walk left (cons (cons k v) (walk right acc)))])))
|
||||
|
||||
(define (treap-has-key? t key)
|
||||
(define order (treap-order t))
|
||||
(let walk ((n (treap-root t)))
|
||||
(match n
|
||||
[(L) #f]
|
||||
[(N k v _ left right)
|
||||
(case (order key k)
|
||||
[(<) (walk left)]
|
||||
[(>) (walk right)]
|
||||
[(=) #t])])))
|
||||
|
||||
(define (treap-height t)
|
||||
(let walk ((n (treap-root t)))
|
||||
(match n
|
||||
[(L) 0]
|
||||
[(N _ _ _ l r) (+ 1 (max (walk l) (walk r)))])))
|
||||
|
|
@ -1,96 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(require "treap.rkt")
|
||||
|
||||
(provide tset?
|
||||
datum-tset
|
||||
make-tset
|
||||
tset-count
|
||||
tset-empty
|
||||
tset-empty?
|
||||
tset-add
|
||||
tset-remove
|
||||
tset-union
|
||||
tset-intersect
|
||||
tset-subtract
|
||||
tset->list
|
||||
tset-member?
|
||||
)
|
||||
|
||||
(require data/order)
|
||||
|
||||
(define (tset? t)
|
||||
(treap? t))
|
||||
|
||||
(define (datum-tset . elts)
|
||||
(make-tset datum-order elts))
|
||||
|
||||
(define (make-tset o elts)
|
||||
(for/fold [(t (tset-empty o))] [(e elts)] (tset-add t e)))
|
||||
|
||||
(define (tset-count t)
|
||||
(treap-size t))
|
||||
|
||||
(define (tset-empty o)
|
||||
(treap-empty o))
|
||||
|
||||
(define (tset-empty? t)
|
||||
(treap-empty? t))
|
||||
|
||||
(define (tset-add t v)
|
||||
(treap-insert t v #t))
|
||||
|
||||
(define (tset-remove t v)
|
||||
(treap-delete t v))
|
||||
|
||||
(define (tset-union t1 t2)
|
||||
(if (< (treap-size t1) (treap-size t2))
|
||||
(treap-fold t1 treap-insert t2)
|
||||
(treap-fold t2 treap-insert t1)))
|
||||
|
||||
(define (tset-intersect t1 t2)
|
||||
(if (< (treap-size t1) (treap-size t2))
|
||||
(treap-fold t1
|
||||
(lambda (t k v) (if (treap-has-key? t2 k) (treap-insert t k v) t))
|
||||
(treap->empty t1))
|
||||
(treap-fold t2
|
||||
(lambda (t k v) (if (treap-has-key? t1 k) (treap-insert t k v) t))
|
||||
(treap->empty t2))))
|
||||
|
||||
(define (tset-subtract t1 t2)
|
||||
(if (< (treap-size t1) (treap-size t2))
|
||||
(treap-fold t1
|
||||
(lambda (t k v) (if (treap-has-key? t2 k) t (treap-insert t k v)))
|
||||
(treap->empty t1))
|
||||
(treap-fold t2
|
||||
(lambda (t k v) (treap-delete t k))
|
||||
t1)))
|
||||
|
||||
(define (tset->list t)
|
||||
(treap-fold t (lambda (acc k v) (cons k acc)) '()))
|
||||
|
||||
(define (tset-member? t k)
|
||||
(treap-has-key? t k))
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
(require data/order)
|
||||
(define (tset . elts) (make-tset datum-order elts))
|
||||
(check-equal? (tset->list (tset 1 2 3 4 5)) '(1 2 3 4 5))
|
||||
(check-equal? (tset->list (tset 5 4 3 2 1)) '(1 2 3 4 5))
|
||||
(check-equal? (tset->list (tset-union (tset 1 2 3) (tset 2 3 4))) '(1 2 3 4))
|
||||
(check-equal? (tset->list (tset-intersect (tset 1 2 3) (tset 2 3 4))) '(2 3))
|
||||
(check-equal? (tset->list (tset-subtract (tset 1 2 3) (tset 2 3 4))) '(1))
|
||||
(check-true (tset-member? (tset 1 2 3) 2))
|
||||
(check-false (tset-member? (tset 1 2 3) 4))
|
||||
(check-true (tset-empty? (tset)))
|
||||
(check-false (tset-empty? (tset 1)))
|
||||
(check-equal? (tset-count (tset 1 2 3)) 3)
|
||||
(check-equal? (tset-count (tset)) 0)
|
||||
(check-equal? (tset-count (tset-union (tset 1 2 3) (tset 2 3 4))) 4)
|
||||
(check-true (tset? (tset-empty datum-order)))
|
||||
(check-true (tset? (tset)))
|
||||
(check-false (tset? 123))
|
||||
(check-false (tset? (list 1 2 3)))
|
||||
(check-false (tset? 'a))
|
||||
)
|
||||
|
|
@ -1,94 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(require (for-syntax syntax/parse))
|
||||
(require (for-syntax racket/base))
|
||||
|
||||
(require racket/match)
|
||||
(require "main.rkt")
|
||||
(require "functional-queue.rkt")
|
||||
|
||||
(provide userland-thread
|
||||
receive
|
||||
do
|
||||
next-event
|
||||
all-queued-events
|
||||
pushback-events!
|
||||
wait-for-gestalt)
|
||||
|
||||
(struct do-command (actions k) #:transparent)
|
||||
(struct receive-command (single? k) #:transparent)
|
||||
(struct pushback-command (events k) #:transparent)
|
||||
|
||||
(define-syntax userland-thread
|
||||
(lambda (stx)
|
||||
(syntax-parse stx
|
||||
[(_ (~or (~optional (~seq #:gestalt g) #:defaults ([g #'(gestalt-empty)]) #:name "#:gestalt")) ...
|
||||
body ...)
|
||||
#`(spawn-userland* (lambda () body ...) g)])))
|
||||
|
||||
(define (spawn-userland* main [initial-gestalt (gestalt-empty)])
|
||||
(spawn (lambda (e k) (k e))
|
||||
(lambda (first-event)
|
||||
(interpret-command (make-queue)
|
||||
(list->queue (list first-event))
|
||||
((reply-to (lambda (dummy)
|
||||
(main)
|
||||
(do (quit))))
|
||||
(void))))
|
||||
initial-gestalt))
|
||||
|
||||
(define-syntax-rule (receive [pat clausebody ...] ...)
|
||||
(receive* (lambda (e sentinel) (match e [pat clausebody ...] ... [_ sentinel]))))
|
||||
|
||||
(define sentinel (cons 'sentinel '()))
|
||||
(define (receive* f)
|
||||
(let loop ((events (all-queued-events)) (discarded-rev '()))
|
||||
(match events
|
||||
[(cons e rest)
|
||||
(call-with-values (lambda () (f e sentinel))
|
||||
(lambda vs
|
||||
(if (equal? vs (list sentinel))
|
||||
(loop rest (cons e discarded-rev))
|
||||
(begin (pushback-events! (reverse discarded-rev))
|
||||
(apply values vs)))))]
|
||||
['()
|
||||
(loop (all-queued-events) discarded-rev)])))
|
||||
|
||||
(define (wait-for-gestalt probe)
|
||||
(receive [(routing-update g)
|
||||
(if (gestalt-empty? (gestalt-filter g probe))
|
||||
(wait-for-gestalt probe)
|
||||
g)]))
|
||||
|
||||
(define (do . actions) (call-in-raw-context (lambda (k) (do-command actions k))))
|
||||
(define (next-event) (call-in-raw-context (lambda (k) (receive-command #t k))))
|
||||
(define (all-queued-events) (call-in-raw-context (lambda (k) (receive-command #f k))))
|
||||
(define (pushback-events! events) (call-in-raw-context (lambda (k) (pushback-command events k))))
|
||||
|
||||
(define prompt (make-continuation-prompt-tag 'minimart-userland))
|
||||
|
||||
(define (reply-to k)
|
||||
(lambda (reply)
|
||||
(call-with-continuation-prompt (lambda () (k reply)) prompt)))
|
||||
|
||||
(define (call-in-raw-context proc)
|
||||
(call-with-composable-continuation
|
||||
(lambda (k) (abort-current-continuation prompt (lambda () (proc (reply-to k)))))
|
||||
prompt))
|
||||
|
||||
(define (interpret-command actions events command)
|
||||
(match command
|
||||
[(do-command new-action-chunk k)
|
||||
(interpret-command (enqueue actions new-action-chunk) events (k (void)))]
|
||||
[(receive-command single? k)
|
||||
(cond
|
||||
[(queue-empty? events)
|
||||
(transition (lambda (e) (and e (interpret-command (make-queue) (list->queue (list e)) command)))
|
||||
(queue->list actions))]
|
||||
[single?
|
||||
(define-values (e rest) (dequeue events))
|
||||
(interpret-command actions rest (k e))]
|
||||
[else
|
||||
(interpret-command actions (make-queue) (k (queue->list events)))])]
|
||||
[(pushback-command events-to-push k)
|
||||
(interpret-command actions (queue-append (list->queue events-to-push) events) (k (void)))]))
|
||||
Loading…
Reference in New Issue