diff --git a/racket/syndicate/actor.rkt b/racket/syndicate/actor.rkt index 3bf4336..186c428 100644 --- a/racket/syndicate/actor.rkt +++ b/racket/syndicate/actor.rkt @@ -58,6 +58,8 @@ ;; schedule-action! + actor-action + (for-syntax (rename-out [name actor-name])) (struct-out field-descriptor) (struct-out field-handle) diff --git a/racket/syndicate/examples/actor/firewall-demo.rkt b/racket/syndicate/examples/actor/firewall-demo.rkt new file mode 100644 index 0000000..2ac943f --- /dev/null +++ b/racket/syndicate/examples/actor/firewall-demo.rkt @@ -0,0 +1,42 @@ +#lang syndicate/actor + +(require syndicate/firewall) + +(struct m (b) #:prefab) +(struct a (v) #:prefab) + +(actor (on (message (m $b)) + (printf "Message: ~v\n" b)) + (on (asserted (a $v)) + (printf "Asserted: ~v\n" v)) + (on (retracted (a $v)) + (printf "Retracted: ~v\n" v))) + +(firewall [(allow (m 'ok1)) + (allow (m 'ok2))] + (on-start (send! (m 'ok1)) + (send! (m 'ok2)) + (send! (m 'must-not-allow)))) + +(firewall [(allow (m ?)) + (forbid (m 'must-not-allow))] + (on-start (send! (m 'ok1)) + (send! (m 'ok2)) + (send! (m 'must-not-allow)))) + +(firewall [(allow (a 'ok1)) + (allow (a (list ?))) + (forbid (a (list 'forbidden))) + (allow (a 'ok2))] + (assert (a 'ok1)) + (assert (a 'ok2)) + (assert (a (list 'ok3))) + (assert (a (list 'forbidden)))) + +(firewall [(allow (a 'ok-wild1)) + (allow (a 'ok-wild2))] + (assert (a _))) + +(firewall [(allow (a 'ok-kid))] + (assert (a 'forbidden-parent)) + (on-start (actor (assert (a _))))) diff --git a/racket/syndicate/firewall.rkt b/racket/syndicate/firewall.rkt new file mode 100644 index 0000000..c5e3bec --- /dev/null +++ b/racket/syndicate/firewall.rkt @@ -0,0 +1,87 @@ +#lang racket/base +;; "Firewall" communications from a process. + +(provide spawn-firewall + (rename-out [firewall-actor firewall])) + +(require (for-syntax racket/base)) +(require (for-syntax syntax/parse)) +(require (for-syntax syntax/srcloc)) + +(require racket/match) +(require (only-in racket/list filter-map)) +(require "core.rkt") +(require "trie.rkt") +(require "pretty.rkt") +(require (only-in "actor.rkt" + react + actor-action + syndicate-effects-available? + schedule-action! + actor-name)) + +(struct firewall (limit ;; AssertionSet + inner ;; Process + ) + #:transparent + #:methods gen:syndicate-pretty-printable + [(define (syndicate-pretty-print f [p (current-output-port)]) + (pretty-print-firewall f p))]) + +(define (pretty-print-firewall f p) + (fprintf p "FIREWALL\n") + (syndicate-pretty-print (process-state (firewall-inner f)) p)) + +(define-syntax (firewall-actor stx) + (syntax-parse stx + [(_ [patch-expr ...] name:actor-name O ...) + (quasisyntax/loc stx + (let* ((inner-action (actor-action #:name name.N (react O ...))) + (limit (apply-patch trie-empty (patch-seq (interpret-patch-expr patch-expr) ...))) + (spawn-action (spawn-firewall limit inner-action))) + (if (syndicate-effects-available?) + (schedule-action! spawn-action) + spawn-action)))])) + +(define-syntax (interpret-patch-expr stx) + (syntax-parse stx + [(_ ((~literal allow) expr)) (syntax/loc stx (assert expr))] + [(_ ((~literal forbid) expr)) (syntax/loc stx (retract expr))])) + +(define (spawn-firewall limit inner-spawn) + (make-spawn (lambda () + (define-values (proc initial-transition) (spawn->process+transition inner-spawn)) + (list firewall-handle-event + (firewall-transition initial-transition (firewall limit proc)) + (process-name proc))))) + +(define (firewall-transition t f) + (match t + [( exn actions) + ( exn (firewall-actions actions (firewall-limit f)))] + [(transition st actions) + (transition (struct-copy firewall f [inner (update-process-state (firewall-inner f) st)]) + (firewall-actions actions (firewall-limit f)))] + [(or #f (? void?)) + t])) + +(define (firewall-actions acs limit) + (filter-map (lambda (ac) (firewall-action ac limit)) (clean-actions acs))) + +(define (firewall-action ac limit) + (match ac + [#f #f] + [(message c) + (and (trie-lookup limit c #f) ;; todo: handle wildcard as a value + (message c))] + [(patch a d) + (patch (trie-intersect a limit #:combiner (lambda (v1 v2) (trie-success v1))) + (trie-intersect d limit #:combiner (lambda (v1 v2) (trie-success v1))))] + [(? spawn? s) + (spawn-firewall limit s)] + [_ + (error 'firewall-action "Cannot filter action ~v" ac)])) + +(define (firewall-handle-event e f) + (define i (firewall-inner f)) + (firewall-transition ((process-behavior i) e (process-state i)) f))