;; lib/acl/tests/inherit.sx — Phase 2: inheritance (groups, resource trees,
;; role expansion) with deny-overrides.

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

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

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

(define
  acl-it-run-all!
  (fn
    ()
    (do
      (let
        ((db (acl-build-db (list (acl-member-of (quote alice) (quote team)) (acl-grant (quote team) (quote read) (quote doc))))))
        (do
          (acl-it-check!
            "group grant reaches member"
            (acl-it-p? db (quote alice) (quote read) (quote doc))
            true)
          (acl-it-check!
            "group grant: non-member excluded"
            (acl-it-p? db (quote bob) (quote read) (quote doc))
            false)
          (acl-it-check!
            "group grant: wrong action"
            (acl-it-p? db (quote alice) (quote edit) (quote doc))
            false)))
      (let
        ((db (acl-build-db (list (acl-member-of (quote alice) (quote team)) (acl-member-of (quote team) (quote org)) (acl-member-of (quote org) (quote company)) (acl-grant (quote company) (quote read) (quote doc))))))
        (do
          (acl-it-check!
            "deep nested group grant reaches leaf member"
            (acl-it-p? db (quote alice) (quote read) (quote doc))
            true)
          (acl-it-check!
            "intermediate group also covered"
            (acl-it-p? db (quote team) (quote read) (quote doc))
            true)
          (acl-it-check!
            "mid group org covered"
            (acl-it-p? db (quote org) (quote read) (quote doc))
            true)))
      (let
        ((db (acl-build-db (list (acl-member-of (quote a) (quote b)) (acl-member-of (quote b) (quote a)) (acl-grant (quote b) (quote read) (quote r))))))
        (do
          (acl-it-check!
            "cyclic membership terminates and grants"
            (acl-it-p? db (quote a) (quote read) (quote r))
            true)
          (acl-it-check!
            "cyclic membership covers both"
            (acl-it-p? db (quote b) (quote read) (quote r))
            true)))
      (let
        ((db (acl-build-db (list (acl-child-of (quote sec) (quote chap)) (acl-child-of (quote chap) (quote book)) (acl-grant (quote u) (quote read) (quote book))))))
        (do
          (acl-it-check!
            "parent grant reaches direct child"
            (acl-it-p? db (quote u) (quote read) (quote chap))
            true)
          (acl-it-check!
            "parent grant reaches deep descendant"
            (acl-it-p? db (quote u) (quote read) (quote sec))
            true)
          (acl-it-check!
            "parent grant covers parent itself"
            (acl-it-p? db (quote u) (quote read) (quote book))
            true)
          (acl-it-check!
            "child grant does not climb to parent"
            (acl-it-p?
              (acl-build-db
                (list
                  (acl-child-of (quote sec) (quote book))
                  (acl-grant (quote u) (quote read) (quote sec))))
              (quote u)
              (quote read)
              (quote book))
            false)))
      (let
        ((db (acl-build-db (list (acl-member-of (quote alice) (quote team)) (acl-child-of (quote post1) (quote board)) (acl-grant (quote team) (quote comment) (quote board))))))
        (do
          (acl-it-check!
            "group + resource: member on child resource"
            (acl-it-p? db (quote alice) (quote comment) (quote post1))
            true)
          (acl-it-check!
            "group + resource: member on parent resource"
            (acl-it-p? db (quote alice) (quote comment) (quote board))
            true)))
      (let
        ((db (acl-build-db (list (acl-member-of (quote bob) (quote editor)) (acl-role-grant (quote editor) (quote edit) (quote page1)) (acl-role-grant (quote editor) (quote read) (quote page1))))))
        (do
          (acl-it-check!
            "role confers edit to member"
            (acl-it-p? db (quote bob) (quote edit) (quote page1))
            true)
          (acl-it-check!
            "role confers read to member"
            (acl-it-p? db (quote bob) (quote read) (quote page1))
            true)
          (acl-it-check!
            "role: capability not in tuple denied"
            (acl-it-p? db (quote bob) (quote moderate) (quote page1))
            false)
          (acl-it-check!
            "role: non-member excluded"
            (acl-it-p? db (quote eve) (quote edit) (quote page1))
            false)))
      (let
        ((db (acl-build-db (list (acl-member-of (quote bob) (quote editor)) (acl-child-of (quote draft) (quote page1)) (acl-role-grant (quote editor) (quote edit) (quote page1))))))
        (acl-it-check!
          "role grant flows to child resource"
          (acl-it-p? db (quote bob) (quote edit) (quote draft))
          true))
      (let
        ((db (acl-build-db (list (acl-member-of (quote alice) (quote team)) (acl-grant (quote team) (quote read) (quote doc)) (acl-deny (quote alice) (quote read) (quote doc))))))
        (acl-it-check!
          "explicit deny beats inherited group allow"
          (acl-it-p? db (quote alice) (quote read) (quote doc))
          false))
      (let
        ((db (acl-build-db (list (acl-member-of (quote alice) (quote team)) (acl-grant (quote alice) (quote read) (quote doc)) (acl-deny (quote team) (quote read) (quote doc))))))
        (do
          (acl-it-check!
            "group deny inherits and overrides direct grant"
            (acl-it-p? db (quote alice) (quote read) (quote doc))
            false)
          (acl-it-check!
            "group deny: another member also blocked"
            (acl-it-p? db (quote team) (quote read) (quote doc))
            false)))
      (let
        ((db (acl-build-db (list (acl-child-of (quote sec) (quote book)) (acl-grant (quote u) (quote read) (quote sec)) (acl-deny (quote u) (quote read) (quote book))))))
        (acl-it-check!
          "ancestor deny overrides descendant grant"
          (acl-it-p? db (quote u) (quote read) (quote sec))
          false))
      (let
        ((db (acl-build-db (list (acl-member-of (quote alice) (quote team)) (acl-grant (quote team) (quote read) (quote doc)) (acl-grant (quote team) (quote edit) (quote doc)) (acl-deny (quote alice) (quote edit) (quote doc))))))
        (do
          (acl-it-check!
            "deny on edit leaves inherited read intact"
            (acl-it-p? db (quote alice) (quote read) (quote doc))
            true)
          (acl-it-check!
            "deny on edit blocks edit"
            (acl-it-p? db (quote alice) (quote edit) (quote doc))
            false)))
      (let
        ((db (acl-build-db (list (acl-member-of (quote alice) (quote team)) (acl-deny (quote team) (quote read) (quote doc))))))
        (acl-it-check!
          "inherited deny, no grant: denied"
          (acl-it-p? db (quote alice) (quote read) (quote doc))
          false))
      (let
        ((db (acl-build-db (list (acl-child-of (quote a) (quote root)) (acl-child-of (quote b) (quote root)) (acl-grant (quote u) (quote read) (quote root)) (acl-deny (quote u) (quote read) (quote a))))))
        (do
          (acl-it-check!
            "deny on sibling a blocks a"
            (acl-it-p? db (quote u) (quote read) (quote a))
            false)
          (acl-it-check!
            "deny on sibling a leaves b permitted"
            (acl-it-p? db (quote u) (quote read) (quote b))
            true)
          (acl-it-check!
            "root itself still permitted"
            (acl-it-p? db (quote u) (quote read) (quote root))
            true)))
      (let
        ((db (acl-build-db (list (acl-grant (quote x) (quote read) (quote y))))))
        (acl-it-check!
          "direct grant under inheritance ruleset"
          (acl-it-p? db (quote x) (quote read) (quote y))
          true)))))

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