diff --git a/syndicate/distributed/gatekeeper.rkt b/syndicate/distributed/gatekeeper.rkt index 2b3c489..4d508ad 100644 --- a/syndicate/distributed/gatekeeper.rkt +++ b/syndicate/distributed/gatekeeper.rkt @@ -17,8 +17,7 @@ (at ds (during (Bind (SturdyRef-oid unvalidated-sturdyref) $key $target) (define sturdyref (validate unvalidated-sturdyref key)) - (define attenuation - (append-map Attenuation-value (reverse (SturdyRef-caveatChain sturdyref)))) + (define attenuation (SturdyRef-caveatChain sturdyref)) (define attenuated-target (apply attenuate-entity-ref target attenuation)) (at observer (assert (embedded attenuated-target)))))])) diff --git a/syndicate/info.rkt b/syndicate/info.rkt index 6b331b0..79bf2d6 100644 --- a/syndicate/info.rkt +++ b/syndicate/info.rkt @@ -27,7 +27,7 @@ )) -(define build-deps '("rackunit-lib")) +(define build-deps '("rackunit-lib" "at-exp-lib")) (define pre-install-collection "private/install.rkt") diff --git a/syndicate/rewrite.rkt b/syndicate/rewrite.rkt index fe831f0..8499df4 100644 --- a/syndicate/rewrite.rkt +++ b/syndicate/rewrite.rkt @@ -30,7 +30,7 @@ (and (walk p v) (begin (set! bindings-rev (cons v bindings-rev)) #t))] - [(Pattern-PAnd ps) (andmap (lambda (p) (walk p v)) ps)] + [(Pattern-PAnd (PAnd ps)) (andmap (lambda (p) (walk p v)) ps)] [(Pattern-PNot p) (let ((saved bindings-rev)) (set! bindings-rev '()) @@ -59,9 +59,9 @@ (define (instantiate-Template t bindings) (let walk ((t t)) (match t - [(Template-TAttenuate (TAttenuate t (Attenuation attenuation))) + [(Template-TAttenuate (TAttenuate t caveats)) (match-define (embedded v) (walk t)) - (embedded (apply attenuate-entity-ref v attenuation))] + (embedded (apply attenuate-entity-ref v caveats))] [(Template-TRef (TRef index)) (if (< index (length bindings)) (list-ref bindings index) @@ -91,20 +91,25 @@ [(? void?) (loop remaining)] [rewritten rewritten])]))] [(Caveat-Rewrite r) - (rewrite r v)])) + (rewrite r v)] + [(Caveat-Reject (Reject pattern)) + (if (match-Pattern pattern v) + (void) + v)] + [(Caveat-unknown v) + (void)])) -;; TODO: prove to myself I've gotten the order correct. (Right-to-left, wasn't it?!?!) -(define (run-rewrites attenuation v) - (let loop ((stages attenuation) (v v)) - (match stages - ['() v] - [(cons stage remaining) (match (examine-alternatives stage v) - [(? void?) (void)] - [rewritten (loop remaining rewritten)])]))) +(define (run-rewrites caveats v) + (let/ec return + (foldr (lambda (c v) (match (examine-alternatives c v) + [(? void?) (return (void))] + [rewritten rewritten])) + v + caveats))) -;; TODO: prove to myself I've gotten the order correct. (Right-to-left, wasn't it?!?!) +;; Extends `r` with `caveats`, which are appended, in the order given, to the sequence of +;; caveats already in `r`, if any. (define (attenuate-entity-ref r . caveats) - (match-define (entity-ref relay target previous-attenuation) r) (if (null? caveats) r - (entity-ref relay target (append previous-attenuation caveats)))) + (struct-copy entity-ref r [attenuation (append (entity-ref-attenuation r) caveats)]))) diff --git a/syndicate/sturdy.rkt b/syndicate/sturdy.rkt index dc56d4f..89c42f9 100644 --- a/syndicate/sturdy.rkt +++ b/syndicate/sturdy.rkt @@ -51,18 +51,17 @@ (define (mint oid key) (SturdyRef oid '() (signature key (sturdy-encode oid)))) -(define (attenuate-sturdy r . attenuation) +(define (update-signature sig caveats) + (for/fold [(sig sig)] [(caveat (in-list caveats))] + (signature sig (sturdy-encode (->preserve caveat))))) + +(define (attenuate-sturdy r . caveats) (match-define (SturdyRef oid caveatChain sig) r) - (SturdyRef oid - (append caveatChain (list attenuation)) - (signature sig (sturdy-encode (->preserve attenuation))))) + (SturdyRef oid (append caveatChain caveats) (update-signature sig caveats))) (define (SturdyRef-valid? r key) (match-define (SturdyRef oid caveatChain actual-sig) r) - (define expected-sig - (for/fold [(sig (signature key (sturdy-encode oid)))] - [(attenuation (in-list caveatChain))] - (signature sig (sturdy-encode (->preserve attenuation))))) + (define expected-sig (update-signature (signature key (sturdy-encode oid)) caveatChain)) (equal? expected-sig actual-sig)) (define (validate r key) diff --git a/syndicate/test/core/rewrite.rkt b/syndicate/test/core/rewrite.rkt new file mode 100644 index 0000000..bab4d48 --- /dev/null +++ b/syndicate/test/core/rewrite.rkt @@ -0,0 +1,71 @@ +#lang at-exp racket/base +;;; SPDX-License-Identifier: LGPL-3.0-or-later +;;; SPDX-FileCopyrightText: Copyright © 2023 Tony Garnock-Jones + +(module+ test + (require rackunit) + (require syndicate/rewrite) + (require syndicate/entity-ref) + (require syndicate/schemas/sturdy) + (require preserves) + + (define (C . strings) (parse-Caveat (string->preserve (apply string-append strings)))) + + (define e0 (entity-ref 'dummy-facet 'dummy-entity '())) + + ;; Allows only 'yes, 'no, and (list x y) through. + (define c1 @C{> ]> > + > ]> > + > <_>]>]> >]>}) + + ;; Changes (list x y) into (list 'swapped y x), leaves everything else alone. + (define c2 @C{> >]> ]>> + > >]>}) + + ;; Rejects 'no. + (define c3 @C{>}) + + ;; An unknown caveat. + (define c4 @C{}) + + (define e1 (attenuate-entity-ref e0 c1)) + + (check-equal? (run-rewrites (entity-ref-attenuation e1) 'yes) 'yes) + (check-equal? (run-rewrites (entity-ref-attenuation e1) 'no) 'no) + (check-equal? (run-rewrites (entity-ref-attenuation e1) '(1 2)) '(1 2)) + (check-equal? (run-rewrites (entity-ref-attenuation e1) '(1 2 3)) (void)) + (check-equal? (run-rewrites (entity-ref-attenuation e1) "yes") (void)) + + (define e12 (attenuate-entity-ref e1 c2)) + + (check-equal? (run-rewrites (entity-ref-attenuation e12) 'yes) 'yes) + (check-equal? (run-rewrites (entity-ref-attenuation e12) 'no) 'no) + (check-equal? (run-rewrites (entity-ref-attenuation e12) '(1 2)) (void)) + (check-equal? (run-rewrites (entity-ref-attenuation e12) '(1 2 3)) (void)) + (check-equal? (run-rewrites (entity-ref-attenuation e12) "yes") (void)) + + (define e21 (attenuate-entity-ref e0 c2 c1)) + + (check-equal? (run-rewrites (entity-ref-attenuation e21) 'yes) 'yes) + (check-equal? (run-rewrites (entity-ref-attenuation e21) 'no) 'no) + (check-equal? (run-rewrites (entity-ref-attenuation e21) '(1 2)) '(swapped 2 1)) + (check-equal? (run-rewrites (entity-ref-attenuation e21) '(1 2 3)) (void)) + (check-equal? (run-rewrites (entity-ref-attenuation e21) "yes") (void)) + + (define e123 (attenuate-entity-ref e12 c3)) + + (check-equal? (run-rewrites (entity-ref-attenuation e123) 'yes) 'yes) + (check-equal? (run-rewrites (entity-ref-attenuation e123) 'no) (void)) + (check-equal? (run-rewrites (entity-ref-attenuation e123) '(1 2)) (void)) + (check-equal? (run-rewrites (entity-ref-attenuation e123) '(1 2 3)) (void)) + (check-equal? (run-rewrites (entity-ref-attenuation e123) "yes") (void)) + + (define e4 (attenuate-entity-ref e0 c4)) + + (check-equal? (run-rewrites (entity-ref-attenuation e4) 'yes) (void)) + (check-equal? (run-rewrites (entity-ref-attenuation e4) 'no) (void)) + (check-equal? (run-rewrites (entity-ref-attenuation e4) '(1 2)) (void)) + (check-equal? (run-rewrites (entity-ref-attenuation e4) '(1 2 3)) (void)) + (check-equal? (run-rewrites (entity-ref-attenuation e4) "yes") (void)) + + ) diff --git a/syndicate/test/core/sturdy.rkt b/syndicate/test/core/sturdy.rkt new file mode 100644 index 0000000..c59d3e9 --- /dev/null +++ b/syndicate/test/core/sturdy.rkt @@ -0,0 +1,29 @@ +#lang at-exp racket/base +;;; SPDX-License-Identifier: LGPL-3.0-or-later +;;; SPDX-FileCopyrightText: Copyright © 2023 Tony Garnock-Jones + +(module+ test + (require rackunit) + (require syndicate/sturdy) + (require preserves) + + (define (C . strings) (parse-SturdyRef (string->preserve (apply string-append strings)))) + + (define s0 (mint "test" #"")) + + (check-equal? s0 (SturdyRef "test" '() #"J\270\253\306N\365\2240\303\206\324\2G\306m\377")) + (check-true (SturdyRef-valid? s0 #"")) + + (define s1 (attenuate-sturdy s0 'a 'b 'c)) + + (check-equal? s1 (SturdyRef "test" '(a b c) #"oO\243\334\366aW6\5\303<\314St\275\226")) + (check-true (SturdyRef-valid? s1 #"")) + (check-false (SturdyRef-valid? + (SturdyRef "test" '(a b c) #"pO\243\334\366aW6\5\303<\314St\275\226") + #"")) + (check-false (SturdyRef-valid? + (SturdyRef "test" '(a c b) #"oO\243\334\366aW6\5\303<\314St\275\226") + #"")) + + ) +