Repair and update attenuation processing

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

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

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

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)

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 <tonyg@leastfixedpoint.com>
+
+(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{<or [<rewrite <and [<bind <_>> <lit yes>]> <ref 0>>
+                     <rewrite <and [<bind <_>> <lit no>]> <ref 0>>
+                     <rewrite <and [<bind <_>> <arr [<_> <_>]>]> <ref 0>>]>})
+
+  ;; Changes (list x y) into (list 'swapped y x), leaves everything else alone.
+  (define c2 @C{<or [<rewrite <arr [<bind <_>> <bind <_>>]> <arr [<lit swapped> <ref 1> <ref 0>]>>
+                     <rewrite <bind <_>> <ref 0>>]>})
+
+  ;; Rejects 'no.
+  (define c3 @C{<reject <lit no>>})
+
+  ;; An unknown caveat.
+  (define c4 @C{<caveat-from-the-year-3000>})
+
+  (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))
+
+  )

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 <tonyg@leastfixedpoint.com>
+
+(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")
+                #""))
+
+  )
+