;; lib/acl/tests/harden.sx — adversarial / cross-phase hardening.
;;
;; Diamond hierarchies, conflict resolution where deny must win through every
;; path, chain inheritance, cycle termination, multi-peer delegation, fact
;; validation, and audit save/restore.
;;
;; PROVER-FREE BY DESIGN: this suite calls only acl-permit? (which runs in
;; compiled Datalog, safe at any depth) plus pure data ops — never acl-explain /
;; acl-prove-d. The SX-side proof reconstructor recurses, and once the kernel
;; JIT-compiles it (after the explain/fed suites warm the process) it loops on
;; chains deeper than ~3 (substrate JIT bug — see plan Blockers). Proof
;; reconstruction is covered by tests/explain.sx (and federated proofs by
;; tests/fed.sx), both of which stay under the warm-process depth threshold.

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

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

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

(define
  acl-hd-run-all!
  (fn
    ()
    (do
      (let
        ((grant-deny (acl-build-db (list (acl-child-of (quote r) (quote p1)) (acl-child-of (quote r) (quote p2)) (acl-grant (quote u) (quote read) (quote p1)) (acl-deny (quote u) (quote read) (quote p2)))))
          (both-grant
            (acl-build-db
              (list
                (acl-child-of (quote r) (quote p1))
                (acl-child-of (quote r) (quote p2))
                (acl-grant (quote u) (quote read) (quote p1))
                (acl-grant (quote u) (quote read) (quote p2))))))
        (do
          (acl-hd-check!
            "diamond resource: grant+deny parents -> deny wins"
            (acl-hd-p? grant-deny (quote u) (quote read) (quote r))
            false)
          (acl-hd-check!
            "diamond resource: both grant -> permit"
            (acl-hd-p? both-grant (quote u) (quote read) (quote r))
            true)
          (acl-hd-check!
            "diamond resource: deny does not leak to other parent"
            (acl-hd-p? grant-deny (quote u) (quote read) (quote p1))
            true)))
      (let
        ((grant-deny (acl-build-db (list (acl-member-of (quote alice) (quote g1)) (acl-member-of (quote alice) (quote g2)) (acl-grant (quote g1) (quote read) (quote doc)) (acl-deny (quote g2) (quote read) (quote doc)))))
          (both-grant
            (acl-build-db
              (list
                (acl-member-of (quote alice) (quote g1))
                (acl-member-of (quote alice) (quote g2))
                (acl-grant (quote g1) (quote read) (quote doc))
                (acl-grant (quote g2) (quote read) (quote doc))))))
        (do
          (acl-hd-check!
            "diamond group: grant+deny groups -> deny wins"
            (acl-hd-p? grant-deny (quote alice) (quote read) (quote doc))
            false)
          (acl-hd-check!
            "diamond group: both grant -> permit"
            (acl-hd-p? both-grant (quote alice) (quote read) (quote doc))
            true)))
      (let
        ((chain (acl-build-db (list (acl-member-of (quote a0) (quote a1)) (acl-member-of (quote a1) (quote a2)) (acl-member-of (quote a2) (quote a3)) (acl-member-of (quote a3) (quote a4)) (acl-grant (quote a4) (quote read) (quote res)))))
          (chain-deny
            (acl-build-db
              (list
                (acl-member-of (quote a0) (quote a1))
                (acl-member-of (quote a1) (quote a2))
                (acl-member-of (quote a2) (quote a3))
                (acl-member-of (quote a3) (quote a4))
                (acl-grant (quote a4) (quote read) (quote res))
                (acl-deny (quote a0) (quote read) (quote res))))))
        (do
          (acl-hd-check!
            "chain: top-group grant reaches leaf member"
            (acl-hd-p? chain (quote a0) (quote read) (quote res))
            true)
          (acl-hd-check!
            "chain: intermediate also covered"
            (acl-hd-p? chain (quote a2) (quote read) (quote res))
            true)
          (acl-hd-check!
            "chain: leaf-member deny overrides top grant"
            (acl-hd-p? chain-deny (quote a0) (quote read) (quote res))
            false)
          (acl-hd-check!
            "chain: deny on leaf does not block sibling level"
            (acl-hd-p? chain-deny (quote a1) (quote read) (quote res))
            true)))
      (let
        ((self-member (acl-build-db (list (acl-member-of (quote a) (quote a)) (acl-grant (quote a) (quote read) (quote r)))))
          (self-child
            (acl-build-db
              (list
                (acl-child-of (quote r) (quote r))
                (acl-grant (quote u) (quote read) (quote r)))))
          (two-cycle
            (acl-build-db
              (list
                (acl-member-of (quote x) (quote y))
                (acl-member-of (quote y) (quote x))
                (acl-grant (quote y) (quote read) (quote r))))))
        (do
          (acl-hd-check!
            "self-membership cycle terminates and grants"
            (acl-hd-p? self-member (quote a) (quote read) (quote r))
            true)
          (acl-hd-check!
            "self-child cycle terminates and grants"
            (acl-hd-p? self-child (quote u) (quote read) (quote r))
            true)
          (acl-hd-check!
            "two-node membership cycle terminates"
            (acl-hd-p? two-cycle (quote x) (quote read) (quote r))
            true)))
      (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-deny (quote alice) (quote read) (quote doc))))))
        (acl-hd-check!
          "federated group grant, local member deny -> deny wins"
          (acl-hd-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 bob) (quote read) (quote doc)) (acl-delegate (quote beta) (quote bob) (quote read) (quote doc))))))
        (acl-hd-check!
          "two peers delegate, one trusted -> permit"
          (acl-hd-p? db (quote bob) (quote read) (quote doc))
          true))
      (let
        ((db (acl-build-db (list (acl-trust (quote alpha) (quote full)) (acl-trust (quote beta) (quote full)) (acl-level-covers (quote full) (quote read)) (acl-delegate (quote alpha) (quote bob) (quote read) (quote doc)) (acl-delegate (quote beta) (quote bob) (quote read) (quote doc))))))
        (acl-hd-check!
          "two peers both trusted -> permit"
          (acl-hd-p? db (quote bob) (quote read) (quote doc))
          true))
      (let
        ((empty (acl-build-db (list))))
        (acl-hd-check!
          "empty db: nothing permitted"
          (acl-hd-p? empty (quote u) (quote read) (quote r))
          false))
      (do
        (acl-hd-check!
          "validate: clean set has no bad facts"
          (len
            (acl-validate-facts
              (list
                (acl-grant (quote u) (quote read) (quote p))
                (acl-member-of (quote u) (quote g))
                (acl-delegate (quote pe) (quote u) (quote read) (quote p)))))
          0)
        (acl-hd-check!
          "validate: facts-valid? true on clean set"
          (acl-facts-valid?
            (list (acl-grant (quote u) (quote read) (quote p))))
          true)
        (acl-hd-check!
          "validate: surfaces wrong-arity and unknown predicate"
          (len
            (acl-validate-facts
              (list
                (acl-grant (quote u) (quote read) (quote p))
                (list (quote grant) (quote u))
                (list (quote bogus) (quote x) (quote y)))))
          2)
        (acl-hd-check!
          "validate: empty set is valid"
          (acl-facts-valid? (list))
          true))
      (let
        ((db (acl-build-db (list (acl-grant (quote u) (quote read) (quote p)) (acl-deny (quote u) (quote edit) (quote p))))))
        (do
          (acl-audit-clear!)
          (acl-audit-decide! db (quote u) (quote read) (quote p))
          (acl-audit-decide! db (quote u) (quote edit) (quote p))
          (let
            ((snap (acl-audit-snapshot)))
            (do
              (acl-audit-clear!)
              (acl-hd-check!
                "audit: cleared count is 0"
                (acl-audit-count)
                0)
              (acl-audit-restore! snap)
              (acl-hd-check!
                "audit: restored count"
                (acl-audit-count)
                2)
              (acl-hd-check!
                "audit: restored last act"
                (get (first (acl-audit-tail 1)) :act)
                (quote edit))
              (acl-audit-decide! db (quote u) (quote comment) (quote p))
              (acl-hd-check!
                "audit: seq continues after restore"
                (get (first (acl-audit-tail 1)) :seq)
                2)
              (acl-hd-check!
                "audit: snapshot is an immutable copy"
                (len (get snap :entries))
                2)
              (acl-audit-clear!))))))))

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