syndicate/firewall

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)

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 _)))))

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
+    [(<quit> exn actions)
+     (<quit> 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))