rose-ash/lib/acl/tests/direct.sx

;; lib/acl/tests/direct.sx — Phase 1: direct grants + deny-overrides.

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

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

;; A small fixture used by most cases: alice can read page1, is denied edit on
;; page1, and a service may federate peer1.
(define
  acl-dt-fixture
  (fn
    ()
    (acl-build-db
      (list
        (acl-actor (quote alice) (quote user))
        (acl-actor (quote svc1) (quote service))
        (acl-resource-fact (quote page1) (quote page))
        (acl-resource-fact (quote peer1) (quote peer))
        (acl-grant (quote alice) (quote read) (quote page1))
        (acl-grant (quote alice) (quote edit) (quote page1))
        (acl-deny (quote alice) (quote edit) (quote page1))
        (acl-grant (quote svc1) (quote federate) (quote peer1))))))

(define
  acl-dt-run-all!
  (fn
    ()
    (let
      ((db (acl-dt-fixture)))
      (do
        (acl-dt-check!
          "direct grant permits"
          (acl-permit? db (quote alice) (quote read) (quote page1))
          true)
        (acl-dt-check!
          "service grant permits federate"
          (acl-permit? db (quote svc1) (quote federate) (quote peer1))
          true)
        (acl-dt-check!
          "missing action denied"
          (acl-permit? db (quote alice) (quote comment) (quote page1))
          false)
        (acl-dt-check!
          "missing resource denied"
          (acl-permit? db (quote alice) (quote read) (quote page2))
          false)
        (acl-dt-check!
          "missing subject denied"
          (acl-permit? db (quote bob) (quote read) (quote page1))
          false)
        (acl-dt-check!
          "wrong subject for service grant denied"
          (acl-permit? db (quote alice) (quote federate) (quote peer1))
          false)
        (acl-dt-check!
          "grant plus deny -> deny wins"
          (acl-permit? db (quote alice) (quote edit) (quote page1))
          false)
        (acl-dt-check!
          "deny alone still denies"
          (acl-permit?
            (acl-build-db
              (list (acl-deny (quote alice) (quote read) (quote page1))))
            (quote alice)
            (quote read)
            (quote page1))
          false)
        (acl-dt-check!
          "deny on edit does not block read"
          (acl-permit? db (quote alice) (quote read) (quote page1))
          true)
        (acl-dt-check!
          "empty db denies"
          (acl-permit?
            (acl-build-db (list))
            (quote alice)
            (quote read)
            (quote page1))
          false)
        (let
          ((db2 (acl-build-db (list (acl-grant (quote a) (quote read) (quote r)) (acl-grant (quote b) (quote read) (quote r)) (acl-deny (quote b) (quote read) (quote r))))))
          (do
            (acl-dt-check!
              "subject a allowed"
              (acl-permit? db2 (quote a) (quote read) (quote r))
              true)
            (acl-dt-check!
              "subject b denied by override"
              (acl-permit? db2 (quote b) (quote read) (quote r))
              false)))
        (let
          ((db3 (acl-build-db (list (acl-actor (quote editors) (quote role)) (acl-grant (quote editors) (quote edit) (quote post1))))))
          (acl-dt-check!
            "role subject direct grant"
            (acl-permit? db3 (quote editors) (quote edit) (quote post1))
            true))
        (do
          (acl/load!
            (list
              (acl-grant (quote carol) (quote moderate) (quote thread1))))
          (acl-dt-check!
            "api permit via current db"
            (acl/permit? (quote carol) (quote moderate) (quote thread1))
            true)
          (acl-dt-check!
            "api deny via current db"
            (acl/permit? (quote carol) (quote read) (quote thread1))
            false))
        (do
          (acl/load! (list))
          (acl-dt-check!
            "api reload clears prior grants"
            (acl/permit? (quote carol) (quote moderate) (quote thread1))
            false))
        (acl-dt-check!
          "schema grant arity valid"
          (acl-fact-valid? (acl-grant (quote x) (quote read) (quote y)))
          true)
        (acl-dt-check!
          "schema bad arity invalid"
          (acl-fact-valid? (list (quote grant) (quote x)))
          false)
        (acl-dt-check!
          "schema unknown predicate invalid"
          (acl-fact-valid? (list (quote frobnicate) (quote x)))
          false)
        (acl-dt-check!
          "schema subject kind known"
          (acl-subject-kind? (quote service))
          true)
        (acl-dt-check!
          "schema resource kind unknown"
          (acl-resource-kind? (quote galaxy))
          false)
        (acl-dt-check!
          "schema known action"
          (acl-known-action? (quote moderate))
          true)
        (acl-dt-check!
          "grant constructor shape"
          (acl-grant (quote u) (quote read) (quote p))
          (list (quote grant) (quote u) (quote read) (quote p)))
        (acl-dt-check!
          "actor constructor shape"
          (acl-actor (quote u) (quote user))
          (list (quote actor) (quote u) (quote user)))))))

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