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

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

;; Name-based deep equality (host `=` compares symbols by unstable interned
;; identity; see lib/acl/tests/explain.sx).
(define
  acl-ft-eq?
  (fn
    (a b)
    (cond
      ((and (list? a) (list? b))
        (and (= (len a) (len b)) (acl-ft-eq-l? a b 0)))
      ((and (symbol? a) (symbol? b))
        (= (symbol->string a) (symbol->string b)))
      (else (= a b)))))
(define
  acl-ft-eq-l?
  (fn
    (a b i)
    (cond
      ((>= i (len a)) true)
      ((not (acl-ft-eq? (nth a i) (nth b i))) false)
      (else (acl-ft-eq-l? a b (+ i 1))))))

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

;; proof leaf walker (federated proofs reconstruct through the engine rule).
(define
  acl-ft-has-leaf?
  (fn
    (node target)
    (cond
      ((= node nil) false)
      ((and (dict? node) (has-key? node :via))
        (acl-ft-eq? (get node :fact) target))
      ((and (dict? node) (has-key? node :body))
        (acl-ft-any-leaf? (get node :body) target))
      (else false))))
(define
  acl-ft-any-leaf?
  (fn
    (nodes target)
    (cond
      ((= (len nodes) 0) false)
      ((acl-ft-has-leaf? (first nodes) target) true)
      (else (acl-ft-any-leaf? (rest nodes) target)))))

(define acl-ft-p? (fn (db s a r) (acl-permit? db s a r)))

;; A standard federation fixture: local trusts peer alpha at "readonly", which
;; covers read+comment. alpha delegates several capabilities to alice.
(define
  acl-ft-fixture
  (fn
    ()
    (acl-build-db
      (list
        (acl-trust (quote alpha) (quote readonly))
        (acl-level-covers (quote readonly) (quote read))
        (acl-level-covers (quote readonly) (quote comment))
        (acl-delegate (quote alpha) (quote alice) (quote read) (quote doc))
        (acl-delegate (quote alpha) (quote alice) (quote edit) (quote doc))))))

(define
  acl-ft-run-all!
  (fn
    ()
    (do
      (let
        ((db (acl-ft-fixture)))
        (do
          (acl-ft-check!
            "trusted delegate, level covers action -> permit"
            (acl-ft-p? db (quote alice) (quote read) (quote doc))
            true)
          (acl-ft-check!
            "trusted delegate, level does NOT cover action -> deny"
            (acl-ft-p? db (quote alice) (quote edit) (quote doc))
            false)
          (acl-ft-check!
            "delegated but action class uncovered (comment has no delegate)"
            (acl-ft-p? db (quote alice) (quote comment) (quote doc))
            false)))
      (let
        ((db (acl-build-db (list (acl-level-covers (quote readonly) (quote read)) (acl-delegate (quote beta) (quote bob) (quote read) (quote doc))))))
        (acl-ft-check!
          "untrusted peer delegate -> deny"
          (acl-ft-p? db (quote bob) (quote read) (quote doc))
          false))
      (let
        ((db (acl-build-db (list (acl-trust (quote alpha) (quote readonly)) (acl-delegate (quote alpha) (quote alice) (quote read) (quote doc))))))
        (acl-ft-check!
          "trust but no level_covers -> deny"
          (acl-ft-p? db (quote alice) (quote read) (quote doc))
          false))
      (let
        ((db (acl-build-db (list (acl-trust (quote alpha) (quote full)) (acl-level-covers (quote full) (quote read)) (acl-delegate (quote alpha) (quote alice) (quote read) (quote doc)) (acl-delegate (quote beta) (quote bob) (quote read) (quote doc))))))
        (do
          (acl-ft-check!
            "trust is per-peer: alpha's delegate applies"
            (acl-ft-p? db (quote alice) (quote read) (quote doc))
            true)
          (acl-ft-check!
            "trust not transitive: beta's delegate does not apply"
            (acl-ft-p? db (quote bob) (quote read) (quote doc))
            false)))
      (let
        ((db (acl-build-db (list (acl-trust (quote alpha) (quote full)) (acl-level-covers (quote full) (quote read)) (acl-delegate (quote alpha) (quote alice) (quote read) (quote doc)) (acl-deny (quote alice) (quote read) (quote doc))))))
        (acl-ft-check!
          "local deny overrides federated grant"
          (acl-ft-p? db (quote alice) (quote read) (quote doc))
          false))
      (let
        ((db (acl-build-db (list (acl-trust (quote alpha) (quote full)) (acl-level-covers (quote full) (quote read)) (acl-member-of (quote alice) (quote team)) (acl-delegate (quote alpha) (quote team) (quote read) (quote doc))))))
        (acl-ft-check!
          "federated grant to group reaches member"
          (acl-ft-p? db (quote alice) (quote read) (quote doc))
          true))
      (let
        ((db (acl-build-db (list (acl-trust (quote alpha) (quote full)) (acl-level-covers (quote full) (quote read)) (acl-child-of (quote sec) (quote book)) (acl-delegate (quote alpha) (quote u) (quote read) (quote book))))))
        (acl-ft-check!
          "federated grant on parent resource reaches child"
          (acl-ft-p? db (quote u) (quote read) (quote sec))
          true))
      (let
        ((transport {:gamma (list (acl-delegate (quote gamma) (quote carol) (quote read) (quote post))) :alpha (list (acl-delegate (quote alpha) (quote alice) (quote read) (quote doc)))}))
        (do
          (acl-ft-check!
            "fetch known peer returns its delegates"
            (len (acl-fed-fetch transport (quote alpha)))
            1)
          (acl-ft-check!
            "fetch unknown peer returns empty"
            (len (acl-fed-fetch transport (quote delta)))
            0)
          (acl-ft-check!
            "collect across peers"
            (len
              (acl-fed-collect transport (list (quote alpha) (quote gamma))))
            2)
          (let
            ((db (acl-fed-build-db (list (acl-trust (quote alpha) (quote readonly)) (acl-trust (quote gamma) (quote readonly)) (acl-level-covers (quote readonly) (quote read))) transport (list (quote alpha) (quote gamma)))))
            (do
              (acl-ft-check!
                "fed-build-db: alpha delegate permits"
                (acl-ft-p? db (quote alice) (quote read) (quote doc))
                true)
              (acl-ft-check!
                "fed-build-db: gamma delegate permits"
                (acl-ft-p? db (quote carol) (quote read) (quote post))
                true)
              (acl-ft-check!
                "fed-build-db: untrusted action still denied"
                (acl-ft-p? db (quote alice) (quote edit) (quote doc))
                false)))))
      (let
        ((db (acl-build-db (list (acl-trust (quote alpha) (quote full)) (acl-level-covers (quote full) (quote read)) (acl-delegate (quote alpha) (quote alice) (quote read) (quote doc))))))
        (do
          (acl-ft-check!
            "before revoke: permitted"
            (acl-ft-p? db (quote alice) (quote read) (quote doc))
            true)
          (acl-revoke!
            db
            (acl-delegate
              (quote alpha)
              (quote alice)
              (quote read)
              (quote doc)))
          (acl-ft-check!
            "after delegate revoked: denied"
            (acl-ft-p? db (quote alice) (quote read) (quote doc))
            false)))
      (let
        ((db (acl-build-db (list (acl-trust (quote alpha) (quote full)) (acl-level-covers (quote full) (quote read)) (acl-delegate (quote alpha) (quote alice) (quote read) (quote doc))))))
        (do
          (acl-ft-check!
            "before trust revoke: permitted"
            (acl-ft-p? db (quote alice) (quote read) (quote doc))
            true)
          (acl-revoke! db (acl-trust (quote alpha) (quote full)))
          (acl-ft-check!
            "after trust revoked: denied"
            (acl-ft-p? db (quote alice) (quote read) (quote doc))
            false)))
      (let
        ((db (acl-build-db (list (acl-level-covers (quote full) (quote read)) (acl-delegate (quote alpha) (quote alice) (quote read) (quote doc))))))
        (do
          (acl-ft-check!
            "delegate without trust: denied"
            (acl-ft-p? db (quote alice) (quote read) (quote doc))
            false)
          (acl-fed-assert! db (acl-trust (quote alpha) (quote full)))
          (acl-ft-check!
            "trust ingested then re-checked: permitted"
            (acl-ft-p? db (quote alice) (quote read) (quote doc))
            true)))
      (let
        ((db (acl-ft-fixture)))
        (let
          ((e (acl-explain db (quote alice) (quote read) (quote doc))))
          (do
            (acl-ft-check! "federated proof allowed?" (get e :allowed?) true)
            (acl-ft-check!
              "federated proof has delegate leaf"
              (acl-ft-has-leaf?
                (get e :proof)
                (list
                  (quote delegate)
                  (quote alpha)
                  (quote alice)
                  (quote read)
                  (quote doc)))
              true)
            (acl-ft-check!
              "federated proof has trust leaf"
              (acl-ft-has-leaf?
                (get e :proof)
                (list (quote trust) (quote alpha) (quote readonly)))
              true)
            (acl-ft-check!
              "federated proof has level_covers leaf"
              (acl-ft-has-leaf?
                (get e :proof)
                (list (quote level_covers) (quote readonly) (quote read)))
              true))))
      (acl-ft-check!
        "schema delegate arity valid"
        (acl-fact-valid?
          (acl-delegate (quote p) (quote s) (quote a) (quote r)))
        true)
      (acl-ft-check!
        "schema trust arity valid"
        (acl-fact-valid? (acl-trust (quote p) (quote l)))
        true)
      (acl-ft-check!
        "schema peer arity valid"
        (acl-fact-valid? (acl-peer (quote p) (quote peer)))
        true)
      (acl-ft-check!
        "schema level_covers arity valid"
        (acl-fact-valid? (acl-level-covers (quote l) (quote read)))
        true)
      (acl-ft-check!
        "schema delegate bad arity invalid"
        (acl-fact-valid? (list (quote delegate) (quote p) (quote s)))
        false))))

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