rose-ash/lib/relations/tests/fed.sx

;; lib/relations/tests/fed.sx — Phase 4: federation (peer links, trust gating,
;; cross-instance chains, revocation). fed-sx transport is mocked as a dict.

(define relations-ft-pass 0)
(define relations-ft-fail 0)
(define relations-ft-failures (list))

(define
  relations-ft-check!
  (fn
    (name got expected)
    (if
      (= got expected)
      (set! relations-ft-pass (+ relations-ft-pass 1))
      (do
        (set! relations-ft-fail (+ relations-ft-fail 1))
        (append!
          relations-ft-failures
          (str name "\n    expected: " expected "\n    got:      " got))))))

(define
  relations-ft-subset?
  (fn
    (xs ys)
    (cond
      ((= (len xs) 0) true)
      ((relations-member? (first xs) ys)
        (relations-ft-subset? (rest xs) ys))
      (else false))))

(define
  relations-ft-set=?
  (fn
    (xs ys)
    (and
      (= (len xs) (len ys))
      (relations-ft-subset? xs ys)
      (relations-ft-subset? ys xs))))

;; Local edge a->b; peerA claims b->c; peerB claims c->d. Local trust only in
;; peerA. With trust gating, a reaches c (via peerA's b->c) but not d.
(define
  relations-ft-facts
  (fn
    ()
    (list
      (relations-rel (quote a) (quote b) (quote parent))
      (relations-peer-rel (quote peerA) (quote b) (quote c) (quote parent))
      (relations-peer-rel (quote peerB) (quote c) (quote d) (quote parent))
      (relations-trust (quote peerA)))))

(define
  relations-ft-run-all!
  (fn
    ()
    (do
      (let
        ((db (relations-build-db (list (relations-rel (quote a) (quote b) (quote parent)) (relations-peer-rel (quote peerX) (quote b) (quote c) (quote parent))))))
        (do
          (relations-ft-check!
            "untrusted link: c not a child of b"
            (relations-children-of db (quote b) (quote parent))
            (list))
          (relations-ft-check!
            "untrusted link: a cannot reach c"
            (relations-reachable? db (quote a) (quote c) (quote parent))
            false)))
      (let
        ((db (relations-build-db (list (relations-rel (quote a) (quote b) (quote parent)) (relations-peer-rel (quote peerX) (quote b) (quote c) (quote parent)) (relations-trust (quote peerX))))))
        (do
          (relations-ft-check!
            "trusted link: c is a child of b"
            (relations-ft-set=?
              (relations-children-of db (quote b) (quote parent))
              (list (quote c)))
            true)
          (relations-ft-check!
            "trusted link: federated reachability a->c"
            (relations-reachable? db (quote a) (quote c) (quote parent))
            true)
          (relations-ft-check!
            "trusted link: connecting path crosses the federated edge"
            (relations-path db (quote a) (quote c) (quote parent))
            (list (quote a) (quote b) (quote c)))))
      (let
        ((db (relations-build-db (relations-ft-facts))))
        (do
          (relations-ft-check!
            "non-transitive: a reaches c (peerA trusted)"
            (relations-reachable? db (quote a) (quote c) (quote parent))
            true)
          (relations-ft-check!
            "non-transitive: a does not reach d (peerB untrusted)"
            (relations-reachable? db (quote a) (quote d) (quote parent))
            false)
          (relations-ft-check!
            "non-transitive: d is not a child of c"
            (relations-children-of db (quote c) (quote parent))
            (list))))
      (let
        ((db (relations-build-db (list (relations-rel (quote a) (quote b) (quote parent)) (relations-peer-rel (quote peerX) (quote b) (quote c) (quote parent)) (relations-trust (quote peerX))))))
        (do
          (relations-ft-check!
            "before link revoke: a reaches c"
            (relations-reachable? db (quote a) (quote c) (quote parent))
            true)
          (relations-revoke!
            db
            (relations-peer-rel
              (quote peerX)
              (quote b)
              (quote c)
              (quote parent)))
          (relations-ft-check!
            "after link revoke: a cannot reach c"
            (relations-reachable? db (quote a) (quote c) (quote parent))
            false)))
      (let
        ((db (relations-build-db (list (relations-rel (quote a) (quote b) (quote parent)) (relations-peer-rel (quote peerX) (quote b) (quote c) (quote parent)) (relations-trust (quote peerX))))))
        (do
          (relations-ft-check!
            "before trust revoke: c is a child of b"
            (relations-ft-set=?
              (relations-children-of db (quote b) (quote parent))
              (list (quote c)))
            true)
          (relations-revoke! db (relations-trust (quote peerX)))
          (relations-ft-check!
            "after trust revoke: federated edge gone"
            (relations-children-of db (quote b) (quote parent))
            (list))
          (relations-ft-check!
            "after trust revoke: local edge survives"
            (relations-ft-set=?
              (relations-children-of db (quote a) (quote parent))
              (list (quote b)))
            true)))
      (let
        ((transport {:peerB (list (relations-peer-rel (quote peerB) (quote c) (quote d) (quote parent))) :peerA (list (relations-peer-rel (quote peerA) (quote b) (quote c) (quote parent)))}))
        (do
          (relations-ft-check!
            "fed-fetch returns a peer's links"
            (len (relations-fed-fetch transport (quote peerA)))
            1)
          (relations-ft-check!
            "fed-fetch unknown peer -> empty"
            (relations-fed-fetch transport (quote nobody))
            (list))
          (relations-ft-check!
            "fed-collect over two peers"
            (len
              (relations-fed-collect
                transport
                (list (quote peerA) (quote peerB))))
            2)
          (let
            ((db (relations-fed-build-db (list (relations-rel (quote a) (quote b) (quote parent)) (relations-trust (quote peerA))) transport (list (quote peerA) (quote peerB)))))
            (do
              (relations-ft-check!
                "fed-build: trusted peerA link binds (a->c)"
                (relations-reachable? db (quote a) (quote c) (quote parent))
                true)
              (relations-ft-check!
                "fed-build: untrusted peerB link does not bind (a->d)"
                (relations-reachable? db (quote a) (quote d) (quote parent))
                false)))))
      (let
        ((db (relations-build-db (list (relations-rel (quote a) (quote b) (quote parent)) (relations-trust (quote peerX))))))
        (do
          (relations-ft-check!
            "before fed-assert: a cannot reach c"
            (relations-reachable? db (quote a) (quote c) (quote parent))
            false)
          (relations-fed-assert!
            db
            (relations-peer-rel
              (quote peerX)
              (quote b)
              (quote c)
              (quote parent)))
          (relations-ft-check!
            "after fed-assert: a reaches c"
            (relations-reachable? db (quote a) (quote c) (quote parent))
            true)))
      (relations-ft-check!
        "peer-rel constructor shape"
        (relations-peer-rel (quote p) (quote s) (quote d) (quote k))
        (list (quote peer_rel) (quote p) (quote s) (quote d) (quote k)))
      (relations-ft-check!
        "trust constructor shape"
        (relations-trust (quote p))
        (list (quote trust) (quote p))))))

(define
  relations-fed-tests-run!
  (fn
    ()
    (do
      (set! relations-ft-pass 0)
      (set! relations-ft-fail 0)
      (set! relations-ft-failures (list))
      (relations-ft-run-all!)
      {:failures relations-ft-failures :total (+ relations-ft-pass relations-ft-fail) :passed relations-ft-pass :failed relations-ft-fail})))