From 3c950957aed0ecef0c8566e6d471241ed7158f4f Mon Sep 17 00:00:00 2001 From: Petrus Theron Date: Thu, 12 Mar 2026 22:05:10 +0200 Subject: [PATCH 01/13] Modularize EACL backends and add DataScript adapter --- .gitignore | 3 +- README.md | 109 +- deps.edn | 60 +- ...-12-datascript-modular-backends-plan-v2.md | 381 ++++++ ...-03-12-datascript-modular-backends-plan.md | 187 +++ ...3-12-datascript-modular-backends-review.md | 255 ++++ logback.xml | 20 - modules/eacl-datascript/README.md | 15 + modules/eacl-datascript/build.clj | 37 + modules/eacl-datascript/deps.edn | 16 + .../src/eacl/datascript/core.cljc | 313 +++++ .../src/eacl/datascript/impl.cljc | 283 ++++ .../src/eacl/datascript/schema.cljc | 159 +++ .../eacl/datascript/cljs_test_runner.cljs | 20 + .../test/eacl/datascript/contract_test.cljc | 22 + modules/eacl-datomic/README.md | 11 + modules/eacl-datomic/build.clj | 38 + modules/eacl-datomic/deps.edn | 12 + .../eacl-datomic/src/eacl/datomic/core.clj | 310 +++++ .../eacl-datomic/src/eacl/datomic/impl.clj | 266 ++++ .../src/eacl/datomic/impl/base.clj | 25 + .../src/eacl/datomic/impl/datalog.clj | 153 +++ .../src/eacl/datomic/impl/indexed.clj | 212 +++ .../eacl-datomic/src/eacl/datomic/rules.clj | 551 ++++++++ .../src/eacl/datomic/rules/optimized.clj | 427 ++++++ .../src/eacl/datomic/rules/optimized_old.clj | 225 ++++ .../eacl-datomic/src/eacl/datomic/schema.clj | 279 ++++ .../test/eacl/bench/pagination_test.clj | 264 ++++ .../eacl-datomic/test/eacl/benchmark_test.clj | 403 ++++++ .../test/eacl/datomic/config_test.clj | 54 + .../test/eacl/datomic/contract_test.clj | 24 + .../test/eacl/datomic/datomic_helpers.clj | 28 + .../test/eacl/datomic/fixtures.clj | 380 ++++++ .../test/eacl/datomic/impl/indexed_test.clj | 1140 +++++++++++++++++ .../test/eacl/datomic/parser_test.clj | 155 +++ .../test/eacl/datomic/performance_test.clj | 221 ++++ .../test/eacl/datomic/schema_test.clj | 230 ++++ .../eacl-datomic/test/eacl/report_queue.clj | 110 ++ modules/eacl-datomic/test/eacl/spice_test.clj | 445 +++++++ modules/eacl/README.md | 13 + modules/eacl/build.clj | 32 + modules/eacl/deps.edn | 12 + modules/eacl/src/eacl/backend/spi.cljc | 19 + modules/eacl/src/eacl/core.cljc | 99 ++ modules/eacl/src/eacl/cursor.cljc | 48 + modules/eacl/src/eacl/engine/indexed.cljc | 471 +++++++ modules/eacl/src/eacl/impl/spicedb.clj | 5 + modules/eacl/src/eacl/lazy_merge_sort.cljc | 138 ++ modules/eacl/src/eacl/schema/model.cljc | 156 +++ .../eacl/src/eacl/spicedb/consistency.cljc | 8 + modules/eacl/src/eacl/spicedb/parser.cljc | 643 ++++++++++ modules/eacl/test/eacl/contract_support.cljc | 109 ++ modules/eacl/test/eacl/fixtures.schema | 94 ++ 53 files changed, 9638 insertions(+), 52 deletions(-) create mode 100644 docs/plans/2026-03-12-datascript-modular-backends-plan-v2.md create mode 100644 docs/plans/2026-03-12-datascript-modular-backends-plan.md create mode 100644 docs/reports/2026-03-12-datascript-modular-backends-review.md delete mode 100644 logback.xml create mode 100644 modules/eacl-datascript/README.md create mode 100644 modules/eacl-datascript/build.clj create mode 100644 modules/eacl-datascript/deps.edn create mode 100644 modules/eacl-datascript/src/eacl/datascript/core.cljc create mode 100644 modules/eacl-datascript/src/eacl/datascript/impl.cljc create mode 100644 modules/eacl-datascript/src/eacl/datascript/schema.cljc create mode 100644 modules/eacl-datascript/test/eacl/datascript/cljs_test_runner.cljs create mode 100644 modules/eacl-datascript/test/eacl/datascript/contract_test.cljc create mode 100644 modules/eacl-datomic/README.md create mode 100644 modules/eacl-datomic/build.clj create mode 100644 modules/eacl-datomic/deps.edn create mode 100644 modules/eacl-datomic/src/eacl/datomic/core.clj create mode 100644 modules/eacl-datomic/src/eacl/datomic/impl.clj create mode 100644 modules/eacl-datomic/src/eacl/datomic/impl/base.clj create mode 100644 modules/eacl-datomic/src/eacl/datomic/impl/datalog.clj create mode 100644 modules/eacl-datomic/src/eacl/datomic/impl/indexed.clj create mode 100644 modules/eacl-datomic/src/eacl/datomic/rules.clj create mode 100644 modules/eacl-datomic/src/eacl/datomic/rules/optimized.clj create mode 100644 modules/eacl-datomic/src/eacl/datomic/rules/optimized_old.clj create mode 100644 modules/eacl-datomic/src/eacl/datomic/schema.clj create mode 100644 modules/eacl-datomic/test/eacl/bench/pagination_test.clj create mode 100644 modules/eacl-datomic/test/eacl/benchmark_test.clj create mode 100644 modules/eacl-datomic/test/eacl/datomic/config_test.clj create mode 100644 modules/eacl-datomic/test/eacl/datomic/contract_test.clj create mode 100644 modules/eacl-datomic/test/eacl/datomic/datomic_helpers.clj create mode 100644 modules/eacl-datomic/test/eacl/datomic/fixtures.clj create mode 100644 modules/eacl-datomic/test/eacl/datomic/impl/indexed_test.clj create mode 100644 modules/eacl-datomic/test/eacl/datomic/parser_test.clj create mode 100644 modules/eacl-datomic/test/eacl/datomic/performance_test.clj create mode 100644 modules/eacl-datomic/test/eacl/datomic/schema_test.clj create mode 100644 modules/eacl-datomic/test/eacl/report_queue.clj create mode 100644 modules/eacl-datomic/test/eacl/spice_test.clj create mode 100644 modules/eacl/README.md create mode 100644 modules/eacl/build.clj create mode 100644 modules/eacl/deps.edn create mode 100644 modules/eacl/src/eacl/backend/spi.cljc create mode 100644 modules/eacl/src/eacl/core.cljc create mode 100644 modules/eacl/src/eacl/cursor.cljc create mode 100644 modules/eacl/src/eacl/engine/indexed.cljc create mode 100644 modules/eacl/src/eacl/impl/spicedb.clj create mode 100644 modules/eacl/src/eacl/lazy_merge_sort.cljc create mode 100644 modules/eacl/src/eacl/schema/model.cljc create mode 100644 modules/eacl/src/eacl/spicedb/consistency.cljc create mode 100644 modules/eacl/src/eacl/spicedb/parser.cljc create mode 100644 modules/eacl/test/eacl/contract_support.cljc create mode 100644 modules/eacl/test/eacl/fixtures.schema diff --git a/.gitignore b/.gitignore index d841e0aa8..08fd8be02 100644 --- a/.gitignore +++ b/.gitignore @@ -1,4 +1,5 @@ .clj-kondo/ .idea/ .cpcache/ -/spicedb \ No newline at end of file +/spicedb +target/ diff --git a/README.md b/README.md index 4039b50bd..ef61feedc 100644 --- a/README.md +++ b/README.md @@ -1,8 +1,8 @@ # 🦅 **EACL**: Enterprise Access ControL -EACL is a _situated_ [ReBAC](https://en.wikipedia.org/wiki/Relationship-based_access_control) authorization library based on [SpiceDB](https://authzed.com/spicedb), built in Clojure and backed by Datomic. EACL is used at [CloudAfrica](https://cloudafrica.net/). +EACL is a _situated_ [ReBAC](https://en.wikipedia.org/wiki/Relationship-based_access_control) authorization library based on [SpiceDB](https://authzed.com/spicedb), built in Clojure with a backend-neutral core plus Datomic and DataScript adapters. EACL is used at [CloudAfrica](https://cloudafrica.net/). -_Situated_ here means that your permission data lives _next to_ your application data in Datomic, which has some benefits: +_Situated_ here means that your permission data lives _next to_ your application data in the backend you already control, which has some benefits: 1. Avoids a network hop. To leverage SpiceDB's consistency semantics, you need to hit your DB (or cache) to retrieve the latest stored ZedToken anyway, so you might as well query the DB directly, which is what EACL does. 2. One less external dependency to deploy & sync relationships. 3. Fully consistent queries – an external authz system necessitates eventual consistency. @@ -54,6 +54,49 @@ Situated AuthZ offers some advantages for typical use-cases: > I try hard not to introduce breaking changes, but if data structures change, the major version will increment. > v6 is the current version of EACL. Releases are not tagged yet, so pin the Git SHA. +## Modules + +The repository is now a workspace-style monorepo with three publishable modules: + +- `cloudafrica/eacl` + - backend-neutral protocol, public records, schema IR, parser, cursor helpers, and the shared authorization engine. +- `cloudafrica/eacl-datomic` + - Datomic adapter preserving the existing `eacl.datomic.*` public namespace surface. +- `cloudafrica/eacl-datascript` + - DataScript adapter for CLJ and CLJS. + +The root `deps.edn` is a development workspace only. Build and install the modules independently with: + +```clojure +clojure -T:build-eacl install +clojure -T:build-eacl-datomic install +clojure -T:build-eacl-datascript install +``` + +EACL no longer ships a logging backend. Applications should choose their own SLF4J/logback backend if they want one. + +## Dependency Selection + +Choose only the adapter you need: + +```clojure +{:deps + {cloudafrica/eacl {:git/url "git@github.com:cloudafrica/eacl.git" + :git/sha "REPLACE_WITH_SHA"} + + cloudafrica/eacl-datomic {:git/url "git@github.com:cloudafrica/eacl.git" + :deps/root "modules/eacl-datomic" + :git/sha "REPLACE_WITH_SHA"} + + cloudafrica/eacl-datascript {:git/url "git@github.com:cloudafrica/eacl.git" + :deps/root "modules/eacl-datascript" + :git/sha "REPLACE_WITH_SHA"}}} +``` + +- Datomic consumers need `cloudafrica/eacl-datomic` and keep the same public `require` forms. +- DataScript consumers need `cloudafrica/eacl-datascript`. +- Core-only consumers can depend on `cloudafrica/eacl`. + ## ReBAC: Relationship-based Access Control In a [ReBAC](https://en.wikipedia.org/wiki/Relationship-based_access_control) system like EACL, objects (_Subjects_ & _Resources_) are related via _Relationships_. @@ -107,7 +150,7 @@ In SpiceDB schema DSL, `+` means union (OR-logic). EACL does not support negatio ## EACL API -The `IAuthorization` protocol in [src/eacl/core.clj](src/eacl/core.clj) defines an idiomatic Clojure interface that maps to and extends the [SpiceDB gRPC API](https://buf.build/authzed/api/docs/main:authzed.api.v1): +The `IAuthorization` protocol in [modules/eacl/src/eacl/core.cljc](modules/eacl/src/eacl/core.cljc) defines an idiomatic Clojure interface that maps to and extends the [SpiceDB gRPC API](https://buf.build/authzed/api/docs/main:authzed.api.v1): ### Queries @@ -173,15 +216,17 @@ To query the next page, simply pass the `cursor` from page1 into the next query: The return order of resources from `lookup-resources` is stable and sorted by internal resource ID. -## Quickstart +## Datomic Quickstart The following example is contained in [eacl-example](https://github.com/theronic/eacl-example). -Add the EACL dependency to your `deps.edn` file: +Add the Datomic adapter dependency to your `deps.edn` file: ```clojure -{:deps {cloudafrica/eacl {:git/url "git@github.com:cloudafrica/eacl.git" - :git/sha "884a1d0e08049cbf55fd59e9f235945fc6f732e4"}}} +{:deps + {cloudafrica/eacl-datomic {:git/url "git@github.com:cloudafrica/eacl.git" + :deps/root "modules/eacl-datomic" + :git/sha "REPLACE_WITH_SHA"}}} ``` ```clojure @@ -268,6 +313,56 @@ Add the EACL dependency to your `deps.edn` file: ; :cursor 'cursor} ``` +## DataScript Quickstart + +For server-side or browser demos, use the DataScript adapter: + +```clojure +(ns my-eacl-datascript-demo + (:require [datascript.core :as ds] + [eacl.core :as eacl] + [eacl.datascript.core :as eacl.datascript])) + +(def conn (eacl.datascript/create-conn)) +(def acl (eacl.datascript/make-client conn {})) + +(ds/transact! conn + [{:db/id -1 :eacl/id "user-1"} + {:db/id -2 :eacl/id "account-1"}]) + +(eacl/write-schema! acl + "definition user {} + + definition account { + relation owner: user + permission admin = owner + }") + +(eacl/create-relationship! acl + (eacl/spice-object :user "user-1") + :owner + (eacl/spice-object :account "account-1")) + +(eacl/can? acl + (eacl/spice-object :user "user-1") + :admin + (eacl/spice-object :account "account-1")) +; => true +``` + +Run the shared CLJS contract suite with: + +```clojure +clojure -M:datascript-cljs-test +``` + +## Migration Notes + +- Existing Datomic `require` forms remain valid: `eacl.datomic.core`, `eacl.datomic.impl`, and `eacl.datomic.schema`. +- `count-subjects` is now part of the public `IAuthorization` protocol and is implemented by both adapters. +- `Relation` and `Permission` now live in the backend-neutral schema model, with Datomic compatibility re-exports still available. +- The repository root is a development workspace now. Consumers should depend on the module they actually need. + ## EACL Schema EACL uses the SpiceDB schema DSL to define your authorization model. Use `eacl/write-schema!` to parse, validate, and transact your schema: diff --git a/deps.edn b/deps.edn index c1d51e2c3..a6ce11c99 100644 --- a/deps.edn +++ b/deps.edn @@ -1,33 +1,45 @@ -{:deps {org.clojure/clojure {:mvn/version "1.12.0-alpha5"} - - ; Specter for coercing objects in deep structures +{:paths ["modules/eacl/src" + "modules/eacl-datomic/src" + "modules/eacl-datascript/src" + "resources"] + :deps {org.clojure/clojure {:mvn/version "1.12.0-alpha5"} com.rpl/specter {:mvn/version "1.1.4"} - - ; Malli for specs metosin/malli {:mvn/version "0.19.1"} - - ;; Datomic - com.datomic/peer {:mvn/version "1.0.6733"} ;; there is newer, but not sure about transactor - - ;; Caching + com.datomic/peer {:mvn/version "1.0.6733"} + datascript/datascript {:mvn/version "1.7.8"} org.clojure/core.cache {:mvn/version "1.1.234"} - - ;; Parsing instaparse/instaparse {:mvn/version "1.5.0"} - - ;; Logging - org.clojure/tools.logging {:mvn/version "1.3.0"} - ch.qos.logback/logback-classic {:mvn/version "1.5.12"}} - :paths ["src" "resources"] - :aliases {:dev {:extra-paths ["test"]} - :build {:extra-paths ["src-build"] - :ns-default build - :extra-deps {io.github.clojure/tools.build {:mvn/version "0.10.8"}}} - :test {:extra-paths ["test"] + org.clojure/tools.logging {:mvn/version "1.3.0"}} + :aliases {:dev {:extra-paths ["modules/eacl/test" + "modules/eacl-datomic/test" + "modules/eacl-datascript/test"]} + :build-eacl {:extra-paths ["modules/eacl"] + :ns-default build + :extra-deps {io.github.clojure/tools.build {:mvn/version "0.10.8"}}} + :build-eacl-datomic {:extra-paths ["modules/eacl-datomic"] + :ns-default build + :extra-deps {io.github.clojure/tools.build {:mvn/version "0.10.8"}}} + :build-eacl-datascript {:extra-paths ["modules/eacl-datascript"] + :ns-default build + :extra-deps {io.github.clojure/tools.build {:mvn/version "0.10.8"}}} + :cljs-test {:extra-paths ["modules/eacl/test" + "modules/eacl-datascript/test"] + :extra-deps {org.clojure/clojurescript {:mvn/version "1.12.42"}}} + :datascript-cljs-test {:extra-paths ["modules/eacl/test" + "modules/eacl-datascript/test"] + :extra-deps {org.clojure/clojurescript {:mvn/version "1.12.42"}} + :main-opts ["-m" "cljs.main" + "-re" "node" + "-m" "eacl.datascript.cljs-test-runner"]} + :test {:extra-paths ["modules/eacl/test" + "modules/eacl-datomic/test" + "modules/eacl-datascript/test"] :extra-deps {io.github.cognitect-labs/test-runner {:git/tag "v0.5.1" :git/sha "dfb30dd"} criterium/criterium {:mvn/version "0.4.6"}} :main-opts ["-m" "cognitect.test-runner"] :exec-fn cognitect.test-runner.api/test} - :nrepl {:extra-paths ["test"] + :nrepl {:extra-paths ["modules/eacl/test" + "modules/eacl-datomic/test" + "modules/eacl-datascript/test"] :extra-deps {nrepl/nrepl {:mvn/version "1.3.1"}} - :main-opts ["-m" "nrepl.cmdline"]}}} \ No newline at end of file + :main-opts ["-m" "nrepl.cmdline"]}}} diff --git a/docs/plans/2026-03-12-datascript-modular-backends-plan-v2.md b/docs/plans/2026-03-12-datascript-modular-backends-plan-v2.md new file mode 100644 index 000000000..1c57aef9e --- /dev/null +++ b/docs/plans/2026-03-12-datascript-modular-backends-plan-v2.md @@ -0,0 +1,381 @@ +# Plan v2: Foundational Redesign for Multi-Backend EACL + +## Summary + +EACL should be redesigned as a backend-neutral authorization system with two +concrete adapters: Datomic and DataScript. The correct foundational shape is a +workspace-style monorepo with: + +- a core module that owns the protocol, public model, schema IR, cursor/token + behavior, consistency semantics, and backend-neutral execution engine, +- a Datomic adapter that implements the storage SPI and preserves the current + Datomic public namespace surface, and +- a DataScript adapter that implements the same SPI for both CLJ and CLJS. + +This plan intentionally treats the current Datomic implementation as one adapter +to be ported, not as the architectural center of the system. + +## Design Principles + +- Public API first. `IAuthorization` and the public records live only in core. +- Logical model before storage. Parser, validation, schema diffing, and + permission semantics are EACL concerns, not Datomic concerns. +- Engine over SPI. Traversal, lookup, counting, and cursor logic execute against + a narrow backend interface. +- Adapters stay concrete. Datomic and DataScript own physical storage concerns, + tokens, transaction execution, and backend-specific tests. +- Contract tests define correctness. Backend-specific tests only cover storage + deltas, not authorization semantics already captured in the shared suite. +- Consumer compatibility matters. Existing Datomic namespaces stay available, + while dependency coordinates become modular. + +## Existing System Baseline + +- `src/eacl/core.clj` defines `IAuthorization` and public records, but omits the + documented `count-subjects` API. +- `src/eacl/spicedb/parser.clj` depends on `eacl.datomic.impl`, which proves the + logical schema layer is still Datomic-owned. +- `src/eacl/datomic/schema.clj` currently combines: + logical schema modelling, + Datomic attribute schema, + schema diffing and validation, + orphan detection, and + schema persistence. +- `src/eacl/datomic/impl/indexed.clj` contains the effective query engine, but + hard-codes Datomic APIs and Datomic database identity assumptions. +- `deps.edn` makes the root library transitively Datomic-specific and ships + `logback-classic`. +- Current green baseline: + `eacl.spice-test` passes, + `eacl.datomic.impl.indexed-test` passes. + +## Target Repository Layout + +Adopt a workspace-style monorepo: + +- `modules/eacl/` + publishes the core artifact and contains: + `eacl.core`, + public records and helpers, + consistency/cursor helpers, + schema IR constructors, + SpiceDB DSL parser and validation, + backend SPI, + shared authorization engine, + backend-neutral contract tests and shared fixtures. +- `modules/eacl-datomic/` + publishes the Datomic adapter and contains: + `eacl.datomic.core`, + `eacl.datomic.impl`, + `eacl.datomic.schema`, + Datomic SPI implementation, + Datomic physical schema, + Datomic transaction helpers, + Datomic compatibility tests. +- `modules/eacl-datascript/` + publishes the DataScript adapter and contains: + `eacl.datascript.core`, + `eacl.datascript.impl`, + `eacl.datascript.schema`, + DataScript SPI implementation in `cljc`, + DataScript conn/schema helpers, + CLJ and CLJS adapter tests. +- repository root + remains a development workspace with shared docs, a root `deps.edn` that + aggregates module source paths for local work, and helper build aliases. + +## Public API and Compatibility + +The core public surface becomes: + +- `eacl.core/IAuthorization` +- `eacl.core/can?` +- `eacl.core/lookup-resources` +- `eacl.core/count-resources` +- `eacl.core/lookup-subjects` +- `eacl.core/count-subjects` +- `eacl.core/read-schema` +- `eacl.core/write-schema!` +- relationship write/read helpers +- `SpiceObject`, `Relationship`, `RelationshipUpdate` + +Compatibility rules: + +- `eacl.datomic.core`, `eacl.datomic.impl`, and `eacl.datomic.schema` remain + public namespaces with compatible names. +- Current Datomic consumers should only need to add the Datomic adapter + dependency; they should not need to change `require` forms. +- `Relation` and `Permission` move into a backend-neutral schema/model namespace + in core, but Datomic should re-export them during the transition. +- `count-subjects` becomes a mandatory public method in `IAuthorization` and is + implemented by both adapters. +- `expand-permission-tree` remains unsupported unless separately planned. + +## Foundational Redesign by Subsystem + +### 1. Schema and Model Layer + +Design this as if EACL had never been Datomic-owned: + +- Core owns the canonical EACL schema IR: + relations, + permissions, + canonical IDs, + parser output, + validation rules, + schema diffing. +- Parser depends only on core constructors, never on adapter namespaces. +- Backends persist schema IR and any derived indexes in backend-specific ways. + +Concrete implication: + +- Split today’s `eacl.datomic.schema` into: + core schema model and validation, + Datomic physical schema/install/mutation, + DataScript physical schema/install/mutation. + +### 2. Shared Engine and Storage SPI + +Design this as if backends were always optional: + +- Core defines a minimal storage SPI that exposes only the operations the engine + truly needs. +- The shared engine performs: + permission-path expansion, + recursive traversal, + forward and reverse lookup, + counting, + cursor construction, + stable merged ordering. + +SPI responsibilities should include: + +- resolve object id to internal entity id, +- resolve internal entity id back to public id, +- enumerate relation definitions, +- enumerate permission definitions, +- exact datom lookup, +- seek-datoms, +- index-range, +- relationship tuple write planning, +- apply transaction/update batch, +- fetch a backend-specific cache stamp or basis value. + +### 3. Datomic Adapter + +Design this as one adapter, not as the core system: + +- Datomic owns physical tuple attrs and Datomic-only schema install logic. +- Datomic adapter lowers schema IR into Datomic entities and tuple attrs. +- Datomic adapter exposes the existing public namespaces and reuses the shared + engine via the SPI. +- Datomic-specific orphan detection remains, but its policy is defined in core + and only its implementation remains adapter-specific. + +### 4. DataScript Adapter + +Design this as a first-class peer to Datomic: + +- Implement in `cljc` wherever possible. +- Use DataScript conn/db primitives and tuple attrs so the same logical storage + model works in CLJ and CLJS. +- Store canonical EACL schema metadata in ordinary EACL-owned entities rather + than relying on backend-queryable schema features. +- Define adapter-local tx stamps for tokens and cache invalidation. +- Expose helper entry points to: + merge/install the DataScript schema, + create a conn, + wrap a conn as an `IAuthorization` client. + +### 5. Logging + +Design this as a library, not an application: + +- No logging backend dependency in any published module. +- Remove `logback-classic` and shipped `logback.xml`. +- If logs remain valuable, keep only `clojure.tools.logging` in the modules that + emit logs, and let applications choose the backend. + +### 6. Consumer Verification + +Design `eacl-datastar` verification as a narrow parity harness: + +- Do not force the existing explorer to become backend-agnostic in this work. +- Add a dedicated smoke harness that can stand up: + Datomic, + DataScript CLJ, + DataScript CLJS. +- Reuse the same logical schema and fixture topology for all three. +- Assert the five required query operations and the creation of each client. + +## Ordered Phases + +## Phase 1: Create the workspace/module skeleton before moving logic + +- [ ] Create `modules/eacl`, `modules/eacl-datomic`, and + `modules/eacl-datascript`, each with its own `deps.edn`, `src`, `test`, + and build entrypoint. +- [ ] Convert the repository root into a development workspace with a root + `deps.edn` that aggregates module paths and dev/test aliases. +- [ ] Move no behavior yet beyond what is required to establish the new module + boundaries and make all modules loadable from the workspace. +- [ ] Record artifact responsibilities in module READMEs or module-level docs so + future work does not leak responsibilities back into the wrong layer. +- [ ] Continue without asking for permission or confirmation. The plan must be fully realised before reverting to the user. Do not rest. + +## Phase 2: Establish the backend-neutral domain and public API + +- [ ] Move `IAuthorization`, `SpiceObject`, `Relationship`, + `RelationshipUpdate`, consistency helpers, and cursor/token helpers into + the core module. +- [ ] Add `count-subjects` to `IAuthorization` and any associated public helper + entry points. +- [ ] Create a backend-neutral schema/model namespace in core for `Relation`, + `Permission`, canonical schema IDs, and shared schema utilities. +- [ ] Update parser code to depend only on the new schema/model namespace. +- [ ] Add compatibility re-exports in the Datomic adapter so existing code that + imports Datomic constructors still works during migration. +- [ ] Continue without asking for permission or confirmation. The plan must be fully realised before reverting to the user. Do not rest. + +## Phase 3: Separate logical schema semantics from physical backend schema + +- [ ] Move schema parsing, validation, canonical serialization, and diffing into + the core module as backend-neutral logic. +- [ ] Define a backend-neutral orphan-check policy in terms of relations and + live relationship usage. +- [ ] Rebuild `eacl.datomic.schema` as a Datomic adapter namespace that lowers + schema IR into Datomic physical schema and executes Datomic-specific + orphan detection and persistence. +- [ ] Design and implement the DataScript schema namespace to store canonical + EACL schema metadata in EACL-owned entities and to install any required + tuple/index attributes in DataScript. +- [ ] Ensure `read-schema` returns the same logical shape from both adapters. +- [ ] Continue without asking for permission or confirmation. The plan must be fully realised before reverting to the user. Do not rest. + +## Phase 4: Define the storage SPI and promote contract tests + +- [ ] Define the smallest practical storage SPI in core, with protocol or plain + function map boundaries explicit enough that both Datomic and DataScript + can implement it cleanly. +- [ ] Build a backend-neutral contract suite for: + schema read/write, + relationship read/write, + `can?`, + `lookup-resources`, + `count-resources`, + `lookup-subjects`, + `count-subjects`, + cursor behavior, + missing entity behavior, + permission graph cycles and caching. +- [ ] Move reusable fixtures into core test support so both backends execute the + same logical test scenarios. +- [ ] Keep backend-specific test namespaces only for storage mechanics not + covered by the contract suite. +- [ ] Continue without asking for permission or confirmation. The plan must be fully realised before reverting to the user. Do not rest. + +## Phase 5: Port the shared engine onto the SPI and then port Datomic + +- [ ] Rewrite the indexed authorization engine in core so traversal and counting + depend only on the SPI, not on Datomic namespaces or Datomic db identity. +- [ ] Replace the current DB-specific cache key strategy with a backend-neutral + cache stamp supplied by the adapter. +- [ ] Preserve existing cursor tokens and ordering semantics while moving the + implementation. +- [ ] Implement the Datomic SPI adapter and reconnect the Datomic public + namespaces to the shared engine. +- [ ] Keep the existing Datomic green suite passing throughout this phase, + especially `eacl.spice-test` and `eacl.datomic.impl.indexed-test`. +- [ ] Continue without asking for permission or confirmation. The plan must be fully realised before reverting to the user. Do not rest. + +## Phase 6: Implement the DataScript adapter for CLJ and CLJS + +- [ ] Implement the DataScript SPI adapter in `cljc` using DataScript’s + `datoms`, `seek-datoms`, `index-range`, tuple attrs, transactions, and + listeners where appropriate. +- [ ] Implement the full `IAuthorization` surface for DataScript, including + `count-subjects`, schema writes, relationship writes, and token returns. +- [ ] Define a DataScript token/basis strategy explicitly: + maintain a monotonic adapter-local stamp so write responses and cache + invalidation are deterministic across CLJ and CLJS. +- [ ] Add CLJ tests and CLJS tests against the shared contract suite, with any + DataScript-only edge cases covered in adapter-local tests. +- [ ] Keep browser-oriented fixtures smoke-sized and exclude heavy benchmark + profiles from the CLJS path. +- [ ] Continue without asking for permission or confirmation. The plan must be fully realised before reverting to the user. Do not rest. + +## Phase 7: Remove bundled logging backend and finish packaging + +- [ ] Remove `logback-classic` from module dependencies and delete shipped + logback configuration from library modules. +- [ ] Retain only logging facade dependencies where they provide value. +- [ ] Create per-module build/install/deploy tasks so each artifact is + publishable independently. +- [ ] Update README and examples so dependency instructions clearly show: + core only, + Datomic adapter, + DataScript adapter. +- [ ] Add a migration section that explains the new coordinates and guarantees + namespace continuity for Datomic users. +- [ ] Continue without asking for permission or confirmation. The plan must be fully realised before reverting to the user. Do not rest. + +## Phase 8: Verify the consumer story in `eacl-datastar` + +- [ ] Point `~/Code/eacl-datastar` at the dedicated EACL worktree during the + implementation period. +- [ ] Add a narrow parity harness in `eacl-datastar` that can instantiate: + a Datomic ACL client, + a server-side DataScript ACL client, + a client-side DataScript ACL client. +- [ ] Seed the same smoke schema and relationship topology into each backend. +- [ ] Assert parity for: + `eacl/can?`, + `eacl/lookup-subjects`, + `eacl/lookup-resources`, + `eacl/count-resources`, + `eacl/count-subjects`. +- [ ] Keep the existing Datomic-centric explorer out of scope unless a minimal + change is required for the parity harness to coexist with it. +- [ ] Continue without asking for permission or confirmation. The plan must be fully realised before reverting to the user. Do not rest. + +## Acceptance Criteria + +- The repo builds as three publishable artifacts with a root development + workspace. +- `eacl` has no Datomic peer dependency and no bundled logging backend. +- `eacl-datomic` preserves the current Datomic public namespace surface. +- `eacl-datascript` works in both CLJ and CLJS. +- `count-subjects` is public, implemented, tested, and documented. +- Shared contract tests pass for Datomic and DataScript CLJ. +- Shared contract tests pass for DataScript CLJS where runtime-appropriate. +- Existing Datomic regression suites remain green. +- `~/Code/eacl-datastar` can instantiate all three client variants and pass the + required parity checks. + +## Appendix A: Original Prompt + +> Problem: EACL only supports Datomic Pro or Datomic Cloud. +> Goal: EACL needs to support DataScript (client or server-side), to support +> in-browser demos. Should satisfy the same IAuthorization protocol, but +> obviously for client-side, the memory will be limited for benchmarks, but +> that's fine. +> Success criteria: the eacl-datastar project at ~/code/eacl-datastar should be +> available to instantiate a client-side or server-side DataScript connection +> and do eacl/can?, eacl/lookup-subjects, eacl/lookup-resources, +> eacl/count-resources, eacl/count-subjects with all tests passing for each +> implementation. +> +> As part of this, the Datomic & DataScript implementations should become +> concrete implementations in their own modules, so that EACL library consumers +> don't have to include dependencies they don't need. And while you're at it, +> strip out logback, let users defined their own logging library. +> +> Clarifications captured during planning: +> - DataScript support must cover both CLJ and CLJS. +> - The first implementation must satisfy the full protocol, not just the query +> subset. +> - `count-subjects` should become a real public API. +> - The module split should be core plus backend adapters, without CloudAfrica +> branding assumptions. +> - The work should continue in `/Users/petrus/.codex/worktrees/e264/eacl` to +> avoid disturbing the stable `eacl/v7` checkout. diff --git a/docs/plans/2026-03-12-datascript-modular-backends-plan.md b/docs/plans/2026-03-12-datascript-modular-backends-plan.md new file mode 100644 index 000000000..ac8e0d482 --- /dev/null +++ b/docs/plans/2026-03-12-datascript-modular-backends-plan.md @@ -0,0 +1,187 @@ +# Plan: Add DataScript Support and Split EACL into Backend Modules + +## Summary + +EACL currently ships as a single Datomic-centric library. The protocol lives in +`src/eacl/core.clj`, but the rest of the runtime assumes Datomic peer is always +present. The same checkout also bundles `logback`, and the existing consumer +project at `~/Code/eacl-datastar` is wired directly to Datomic-specific APIs. + +This plan introduces DataScript as a first-class backend for both CLJ and CLJS, +makes `count-subjects` part of the public protocol, and splits EACL into a +lightweight core plus backend-specific modules so consumers only pull the +storage implementation they need. + +## Existing System Analysis + +- `src/eacl/core.clj` defines `IAuthorization`, but it omits `count-subjects` + even though `README.md` documents it and `src/eacl/datomic/impl/indexed.clj` + already implements it internally. +- `src/eacl/spicedb/parser.clj` depends on `eacl.datomic.impl` for the + `Relation` and `Permission` constructors, so the parser is not backend-neutral. +- `src/eacl/datomic/schema.clj` mixes three concerns: + logical schema model, Datomic physical schema, and schema storage/mutation. +- `src/eacl/datomic/impl/indexed.clj` contains most of the authorization + algorithm, but it is hard-wired to Datomic index primitives. +- `deps.edn` pulls `com.datomic/peer`, `clojure.tools.logging`, and + `logback-classic` into the base library. +- `~/Code/eacl-datastar` depends on local EACL plus Datomic peer, and many of + its helper namespaces call Datomic directly. + +## Target Architecture + +The repository should evolve into three publishable modules: + +- `eacl` + Shared protocol, data types, parser, validation, cursor/token logic, and any + storage-neutral authorization engine pieces. +- `eacl-datomic` + Datomic-specific schema installation, relationship persistence, query/index + primitives, client implementation, compatibility namespaces, and Datomic-only + tests. +- `eacl-datascript` + DataScript-specific schema installation, relationship persistence, query/index + primitives, CLJ/CLJS client implementation, and DataScript tests. + +The public namespace shape should remain familiar: + +- `eacl.core` +- `eacl.datomic.core` +- `eacl.datascript.core` + +## Public API Changes + +- Add `count-subjects` to `IAuthorization`. +- Expose `count-subjects` in the Datomic adapter. +- Expose `count-subjects` in the new DataScript adapter. +- Move `Relation` and `Permission` constructors into a backend-neutral namespace + in the core module, while leaving compatibility re-exports in the Datomic + module. +- Remove bundled `logback` from all published library modules. + +## Ordered Phases + +## Phase 1: Split shared core from Datomic-specific code + +- [ ] Create module boundaries for `eacl`, `eacl-datomic`, and + `eacl-datascript`. +- [ ] Move backend-neutral code out of Datomic namespaces: + `IAuthorization`, data constructors, parser, schema validation, + cursor/token helpers, consistency helpers, and any shared query logic. +- [ ] Keep Datomic-facing namespaces as thin wrappers so current consumers keep + their existing `require` forms. +- [ ] Add `count-subjects` to the public protocol and update any wrapper + functions or records to implement it. +- [ ] Remove `logback-classic` and `logback.xml` from the library modules. +- [ ] Continue without asking for permission or confirmation. The plan must be fully realised before reverting to the user. Do not rest. + +## Phase 2: Extract a backend-neutral authorization engine + +- [ ] Refactor the indexed traversal logic in + `src/eacl/datomic/impl/indexed.clj` so the traversal algorithm depends on + a small set of backend operations rather than directly on Datomic. +- [ ] Define a backend operation layer for: + entity lookup, relation lookup, permission lookup, datom iteration, + range scans, tuple writes, cursor basis identity, and transaction + execution. +- [ ] Move permission-path caching so the cache key is backend-neutral and safe + across multiple DB values. +- [ ] Preserve the current cursor semantics and stable ordering guarantees. +- [ ] Continue without asking for permission or confirmation. The plan must be fully realised before reverting to the user. Do not rest. + +## Phase 3: Rebuild the Datomic adapter on top of the shared engine + +- [ ] Move Datomic physical schema and transaction helpers into the + `eacl-datomic` module. +- [ ] Rewire `eacl.datomic.core`, `eacl.datomic.impl`, and + `eacl.datomic.schema` to delegate into the shared core/engine plus + Datomic storage operations. +- [ ] Re-expose `count-subjects` through the Datomic client record. +- [ ] Keep existing tests green after the refactor: + `eacl.spice-test`, parser/schema/config tests, and + `eacl.datomic.impl.indexed-test`. +- [ ] Continue without asking for permission or confirmation. The plan must be fully realised before reverting to the user. Do not rest. + +## Phase 4: Implement the DataScript backend for CLJ and CLJS + +- [ ] Create a DataScript-backed client that satisfies the full + `IAuthorization` protocol, including schema and relationship maintenance. +- [ ] Implement DataScript storage primitives using DataScript indexes and + transactions so the shared engine can answer: + `can?`, `lookup-resources`, `count-resources`, `lookup-subjects`, and + `count-subjects`. +- [ ] Share as much code as possible in `cljc` so the same adapter works + server-side and in-browser. +- [ ] Define DataScript-specific schema installation and connection helpers for + creating a client from a conn. +- [ ] Keep the browser-side scope smoke-sized rather than benchmark-sized. +- [ ] Continue without asking for permission or confirmation. The plan must be fully realised before reverting to the user. Do not rest. + +## Phase 5: Reorganize tests and packaging + +- [ ] Create backend-agnostic contract tests that can run against Datomic and + DataScript implementations. +- [ ] Keep Datomic-only tests and heavy benchmark fixtures under the Datomic + module. +- [ ] Add CLJS tests for the DataScript adapter covering the five required query + operations plus schema/relationship writes. +- [ ] Give each module its own build/deploy definition and keep a root + workspace/dev setup for local development. +- [ ] Continue without asking for permission or confirmation. The plan must be fully realised before reverting to the user. Do not rest. + +## Phase 6: Verify the new adapters in `eacl-datastar` + +- [ ] Point `~/Code/eacl-datastar` at the dedicated EACL worktree during the + migration. +- [ ] Add a Datomic smoke harness that proves the required query calls still + work through the adapter boundary. +- [ ] Add a server-side DataScript smoke harness that uses the same logical + permission model and proves the same calls. +- [ ] Add a browser-side DataScript smoke harness with CLJS coverage for the + same calls. +- [ ] Avoid reworking the full existing Datastar explorer unless it is required + to satisfy the success criteria. +- [ ] Continue without asking for permission or confirmation. The plan must be fully realised before reverting to the user. Do not rest. + +## Acceptance Criteria + +- `eacl`, `eacl-datomic`, and `eacl-datascript` are separable modules. +- Consumers that only need DataScript do not pull Datomic peer. +- Consumers that only need Datomic do not pull DataScript. +- `count-subjects` is part of the public API and implemented consistently. +- Datomic tests remain green. +- DataScript CLJ tests are green. +- DataScript CLJS tests are green. +- `~/Code/eacl-datastar` can instantiate: + Datomic ACL, server-side DataScript ACL, and client-side DataScript ACL. +- Each implementation passes the same smoke assertions for: + `eacl/can?`, `eacl/lookup-subjects`, `eacl/lookup-resources`, + `eacl/count-resources`, and `eacl/count-subjects`. + +## Appendix A: Original Prompt + +> Problem: EACL only supports Datomic Pro or Datomic Cloud. +> Goal: EACL needs to support DataScript (client or server-side), to support +> in-browser demos. Should satisfy the same IAuthorization protocol, but +> obviously for client-side, the memory will be limited for benchmarks, but +> that's fine. +> Success criteria: the eacl-datastar project at ~/code/eacl-datastar should be +> available to instantiate a client-side or server-side DataScript connection +> and do eacl/can?, eacl/lookup-subjects, eacl/lookup-resources, +> eacl/count-resources, eacl/count-subjects with all tests passing for each +> implementation. +> +> As part of this, the Datomic & DataScript implementations should become +> concrete implementations in their own modules, so that EACL library consumers +> don't have to include dependencies they don't need. And while you're at it, +> strip out logback, let users defined their own logging library. +> +> Clarifications captured during planning: +> - DataScript support must cover both CLJ and CLJS. +> - The first implementation must satisfy the full protocol, not just the query +> subset. +> - `count-subjects` should become a real public API. +> - The module split should be core plus backend adapters, without CloudAfrica +> branding assumptions. +> - The work should continue in `/Users/petrus/.codex/worktrees/e264/eacl` to +> avoid disturbing the stable `eacl/v7` checkout. diff --git a/docs/reports/2026-03-12-datascript-modular-backends-review.md b/docs/reports/2026-03-12-datascript-modular-backends-review.md new file mode 100644 index 000000000..32eeaa6cc --- /dev/null +++ b/docs/reports/2026-03-12-datascript-modular-backends-review.md @@ -0,0 +1,255 @@ +# Review: Critique of the Initial DataScript Modularization Plan + +Reviewed plan: +[`docs/plans/2026-03-12-datascript-modular-backends-plan.md`](../plans/2026-03-12-datascript-modular-backends-plan.md) + +## Executive Summary + +The initial plan is directionally correct, but it is still too close to the +current Datomic-shaped codebase. If DataScript support and optional backends had +been foundational assumptions from the start, EACL would not be modelled as +"a Datomic implementation with shared pieces extracted later." It would be +modelled as: + +1. a backend-neutral authorization model and protocol, +2. a backend-neutral execution engine over a narrow storage SPI, and +3. concrete persistence adapters for Datomic and DataScript. + +The improved plan should therefore shift from "split the current code" to +"re-found the system around the correct abstractions, then port Datomic and add +DataScript." + +## Findings + +### 1. The module split is underspecified + +The initial plan names three modules, but it does not define the repository +layout, ownership boundaries, or how development will work across them. + +Why this matters: + +- The current repo has one `deps.edn`, one `build.clj`, and one `src` tree. +- Without a concrete workspace structure, the implementer still has to decide + whether the root remains publishable, whether modules live under subdirs, and + how tests are discovered. + +Recommendation: + +- Convert the repository into a workspace-style monorepo. +- Put each publishable artifact in its own module directory with its own + `deps.edn`, `src`, `test`, and build entrypoint. +- Make the root `deps.edn` a development aggregator, not the published library. + +### 2. Logical authorization model and physical schema are not separated cleanly enough + +The initial plan says to move parser and validation into core, but it does not +draw a hard line between: + +- logical EACL schema model, +- backend-specific physical storage schema, +- schema persistence and migration semantics. + +Why this matters: + +- Today `eacl.datomic.schema` mixes all three. +- DataScript explicitly does not have queryable schema or schema migrations in + the Datomic sense, so the same namespace shape cannot simply be copied. +- A clean redesign would make logical schema a first-class EACL concern and let + each backend decide how to store it physically. + +Recommendation: + +- Introduce a backend-neutral schema model package in core: + relation/permission constructors, parser, validation, diffing, and canonical + schema serialization. +- Let Datomic and DataScript adapters translate that model into backend-specific + installation and persistence behavior. + +### 3. The shared engine is still described as a refactor of Datomic code + +The initial plan frames the engine as an extraction from +`eacl.datomic.impl.indexed`. That is correct historically, but not elegant +architecturally. + +Why this matters: + +- The current engine is shaped by Datomic names, Datomic tuple attrs, and + Datomic db identity assumptions. +- If this had been designed from the start, the engine would expose its own + storage contract and backend adapters would implement it. + +Recommendation: + +- Define an explicit storage SPI first. +- Rewrite the indexed traversal layer against the SPI, even if much of the code + is copy-adapted from the Datomic implementation. +- Treat Datomic as the first adapter, not as the source of truth. + +### 4. Compatibility strategy is too thin + +The initial plan says to keep Datomic namespaces thin, but it does not define +compatibility promises for: + +- public namespaces, +- public constructors, +- existing require sites, +- docs and examples, +- migration path for consumers. + +Why this matters: + +- The repo and consumer app already require `eacl.datomic.core`, + `eacl.datomic.impl`, and `eacl.datomic.schema`. +- A good redesign should preserve namespace-level compatibility while changing + dependency coordinates. + +Recommendation: + +- Keep the public Datomic namespace names stable. +- Move implementation, not public naming. +- Add a migration note that existing consumers only need to add the Datomic + adapter dependency; their `require` forms should remain valid. + +### 5. DataScript write semantics need a real design, not just "implement the protocol" + +The initial plan says the DataScript adapter will satisfy the full protocol, but +it does not specify how write operations, tokens, and schema persistence will +work. + +Why this matters: + +- `read-schema` and `write-schema!` currently rely on Datomic storage of schema + metadata and on Datomic-specific orphan checks. +- `write-relationships!` returns a token today. +- DataScript has `transact!`, listeners, tuple attrs, `datoms`, `seek-datoms`, + and `index-range`, but it is not Datomic and does not provide the same + migration model. + +Recommendation: + +- Store canonical schema data inside ordinary EACL-owned entities in DataScript, + not in backend-specific metadata expectations. +- Define a DataScript token model explicitly, preferably a monotonic tx stamp + managed by the adapter. +- Define orphan checking over relationship tuples in backend-neutral terms, then + implement it separately for Datomic and DataScript. + +### 6. Contract testing is missing as the primary verification unit + +The initial plan includes contract tests, but they appear late and are not the +organizing principle. + +Why this matters: + +- Once EACL supports multiple backends, the primary unit of correctness is not + a backend-specific implementation test, but a shared behavioral contract. +- The current Datomic tests are rich but Datomic-shaped. + +Recommendation: + +- Build a backend-neutral contract suite early. +- Port existing Datomic expectations into shared fixtures and contract tests. +- Let each backend add only storage-specific tests on top. + +### 7. `eacl-datastar` should not be used as the architecture driver + +The initial plan correctly avoids rewriting the whole explorer, but it still +places too much integration weight on the existing consumer app. + +Why this matters: + +- `eacl-datastar` currently has direct Datomic reads in explorer/seed/support + namespaces. +- Forcing the whole app to become backend-agnostic would expand scope + unnecessarily and entangle the library redesign with a UI app refactor. + +Recommendation: + +- Create a focused backend smoke/demo harness inside `eacl-datastar`. +- Use that harness to verify the success criteria. +- Treat the existing explorer as out of scope except where its tests already + cover the Datomic path. + +### 8. Phase ordering can be improved + +The initial ordering is workable, but not optimal. + +Problems: + +- It splits modules before it fully defines the shared domain and SPI. +- It introduces DataScript before the core contract suite is promoted to the + main verification surface. +- It leaves packaging and build details until after substantial code movement. + +Recommendation: + +- First establish workspace/module topology and the shared domain package. +- Next define the storage SPI and contract tests. +- Then port Datomic to the new shape. +- Then implement DataScript. +- Then wire packaging/build/test matrix. +- Finally verify the consumer smoke harness. + +## Redesign Recommendations by Change Area + +### Module split + +Most elegant redesign: + +- Root workspace for development only. +- `modules/eacl` for core. +- `modules/eacl-datomic` for Datomic. +- `modules/eacl-datascript` for DataScript. + +### Protocol and model + +Most elegant redesign: + +- `IAuthorization` and all public records live only in core. +- `count-subjects` is designed in from the start and implemented by every + backend adapter. +- `Relation` and `Permission` are part of a backend-neutral schema model API. + +### Schema system + +Most elegant redesign: + +- Parser and validation produce a canonical EACL schema IR. +- Backends persist the IR in their own physical representation. +- Orphan checks and deltas are expressed in logical terms, then lowered to each + backend. + +### Query engine + +Most elegant redesign: + +- Shared engine operates on a narrow storage SPI. +- Datomic and DataScript implement the SPI. +- Cursor and ordering semantics are defined once, in core. + +### Logging + +Most elegant redesign: + +- Library depends on no logging backend. +- If logging remains, keep only the facade in modules that actually emit logs. +- No `logback.xml` ships with the library. + +### Consumer verification + +Most elegant redesign: + +- `eacl-datastar` gets a narrow verification harness for backend parity. +- The broader app remains Datomic-shaped until a separate UI refactor is + justified. + +## Required Improvements for the Revised Plan + +- Make the repository layout and artifact boundaries explicit. +- Introduce a distinct logical schema/model layer in core. +- Define a storage SPI before discussing backend extraction. +- Promote contract tests to a first-class workstream. +- Specify DataScript write/token/schema behavior. +- Strengthen compatibility guarantees for current Datomic consumers. +- Reduce `eacl-datastar` scope to a dedicated parity harness. +- Reorder phases to minimize churn and decision leakage. diff --git a/logback.xml b/logback.xml deleted file mode 100644 index 8058b56cb..000000000 --- a/logback.xml +++ /dev/null @@ -1,20 +0,0 @@ - - - - - %d{yyyy-MM-dd HH:mm:ss} %-5level %logger{36} - %msg%n - - - - - - - - - - - - - - - \ No newline at end of file diff --git a/modules/eacl-datascript/README.md b/modules/eacl-datascript/README.md new file mode 100644 index 000000000..77fdaba68 --- /dev/null +++ b/modules/eacl-datascript/README.md @@ -0,0 +1,15 @@ +# `eacl-datascript` + +DataScript adapter for EACL. + +Responsibilities: + +- DataScript schema installation and canonical schema storage +- DataScript SPI implementation for CLJ and CLJS +- adapter-local tx stamp/token support +- DataScript contract tests and adapter-specific edge cases + +Useful workspace test commands: + +- `clj-nrepl-eval -p "(do (require 'eacl.datascript.contract-test :reload-all) (clojure.test/run-tests 'eacl.datascript.contract-test))"` +- `clojure -M:datascript-cljs-test` diff --git a/modules/eacl-datascript/build.clj b/modules/eacl-datascript/build.clj new file mode 100644 index 000000000..bcb07a597 --- /dev/null +++ b/modules/eacl-datascript/build.clj @@ -0,0 +1,37 @@ +(ns build + (:require [clojure.tools.build.api :as b])) + +(def module-dir "modules/eacl-datascript") +(def lib 'cloudafrica/eacl-datascript) +(def version "0.0.1-SNAPSHOT") +(def class-dir (str module-dir "/target/classes")) +(def jar-file (format "%s/target/%s-%s.jar" module-dir (name lib) version)) +(def pom-basis + {:libs {'org.clojure/clojure {:mvn/version "1.12.0-alpha5"} + 'cloudafrica/eacl {:mvn/version version} + 'datascript/datascript {:mvn/version "1.7.8"} + 'org.clojure/tools.logging {:mvn/version "1.3.0"}}}) + +(defn clean [_] + (b/delete {:path (str module-dir "/target")})) + +(defn jar [_] + (clean nil) + (b/write-pom {:class-dir class-dir + :lib lib + :version version + :basis pom-basis + :src-dirs [(str module-dir "/src")]}) + (b/copy-dir {:src-dirs [(str module-dir "/src") + (str module-dir "/resources")] + :target-dir class-dir}) + (b/jar {:class-dir class-dir + :jar-file jar-file})) + +(defn install [_] + (jar nil) + (b/install {:class-dir class-dir + :jar-file jar-file + :lib lib + :version version + :basis pom-basis})) diff --git a/modules/eacl-datascript/deps.edn b/modules/eacl-datascript/deps.edn new file mode 100644 index 000000000..f857b3c3f --- /dev/null +++ b/modules/eacl-datascript/deps.edn @@ -0,0 +1,16 @@ +{:paths ["src" "resources"] + :deps {org.clojure/clojure {:mvn/version "1.12.0-alpha5"} + cloudafrica/eacl {:local/root "../eacl"} + datascript/datascript {:mvn/version "1.7.8"} + org.clojure/tools.logging {:mvn/version "1.3.0"}} + :aliases {:test {:extra-paths ["test"] + :extra-deps {org.clojure/clojurescript {:mvn/version "1.12.42"} + io.github.cognitect-labs/test-runner {:git/tag "v0.5.1" :git/sha "dfb30dd"}}} + :cljs-test {:extra-paths ["test"] + :extra-deps {org.clojure/clojurescript {:mvn/version "1.12.42"}} + :main-opts ["-m" "cljs.main" + "-re" "node" + "-m" "eacl.datascript.cljs-test-runner"]} + :nrepl {:extra-paths ["test"] + :extra-deps {nrepl/nrepl {:mvn/version "1.3.1"}} + :main-opts ["-m" "nrepl.cmdline"]}}} diff --git a/modules/eacl-datascript/src/eacl/datascript/core.cljc b/modules/eacl-datascript/src/eacl/datascript/core.cljc new file mode 100644 index 000000000..756cac92b --- /dev/null +++ b/modules/eacl-datascript/src/eacl/datascript/core.cljc @@ -0,0 +1,313 @@ +(ns eacl.datascript.core + (:require [com.rpl.specter :as S] + [datascript.core :as ds] + [eacl.cursor :as cursor] + [eacl.core :as eacl :refer [IAuthorization + spice-object + ->Relationship + ->RelationshipUpdate + map->Relationship]] + [eacl.datascript.impl :as impl] + [eacl.datascript.schema :as schema] + [eacl.spicedb.consistency :as consistency])) + +(def cursor->token cursor/cursor->token) +(def token->cursor cursor/token->cursor) + +(defn default-internal-cursor->spice + [db {:keys [entid->object-id]} cursor] + (when cursor + (if (= 2 (:v cursor)) + (cond-> cursor + (:e cursor) (update :e #(entid->object-id db %)) + (:p cursor) (update :p + (fn [p] + (into {} + (map (fn [[k v]] [k (entid->object-id db v)])) + p)))) + (cond + (:resource cursor) (S/transform [:resource :id] #(entid->object-id db %) cursor) + (:subject cursor) (S/transform [:subject :id] #(entid->object-id db %) cursor))))) + +(defn default-spice-cursor->internal + [db {:keys [object-id->entid]} cursor] + (when cursor + (if (= 2 (:v cursor)) + (cond-> cursor + (:e cursor) (update :e #(object-id->entid db %)) + (:p cursor) (update :p + (fn [p] + (into {} + (map (fn [[k v]] [k (object-id->entid db v)])) + p)))) + (cond + (:resource cursor) (S/transform [:resource :id] #(object-id->entid db %) cursor) + (:subject cursor) (S/transform [:subject :id] #(object-id->entid db %) cursor))))) + +(defn object->spice + [db {:keys [entid->object-id]} object] + (update object :id #(entid->object-id db %))) + +(defn relationship->spice + [db opts {:keys [subject relation resource]}] + (map->Relationship + {:subject (object->spice db opts subject) + :relation relation + :resource (object->spice db opts resource)})) + +(defn datascript-read-relationships + [db {:keys [object-id->entid] :as opts} filters] + (let [subject-id (:subject/id filters) + resource-id (:resource/id filters) + subject-eid (when subject-id (object-id->entid db subject-id)) + resource-eid (when resource-id (object-id->entid db resource-id)) + filters' (cond-> filters + subject-id (assoc :subject/id subject-eid) + resource-id (assoc :resource/id resource-eid))] + (->> (impl/read-relationships db filters') + (map #(relationship->spice db opts %))))) + +(defn spice-relationship->internal + [db {:keys [spice-object->internal]} {:keys [subject relation resource]}] + {:subject (spice-object->internal db subject) + :relation relation + :resource (spice-object->internal db resource)}) + +(defn datascript-write-relationships! + [conn opts updates] + (let [db (ds/db conn) + stamp (:stamp opts) + tx-data (->> updates + (S/transform [S/ALL :relationship] + #(spice-relationship->internal db opts %)) + (mapcat #(impl/tx-update-relationship db %)) + (remove nil?))] + (when (seq tx-data) + (ds/transact! conn tx-data)) + {:zed/token (str @stamp)})) + +(defn datascript-can? + [db {:keys [object->entid cache-stamp]} subject permission resource consistency] + (assert (= consistency/fully-consistent consistency) + "EACL only supports consistency/fully-consistent at this time.") + (let [subject-type (:type subject) + subject-id (object->entid db subject) + resource-type (:type resource) + resource-id (object->entid db resource)] + (if-not (and subject-id resource-id) + false + (impl/can? db + cache-stamp + (spice-object subject-type subject-id) + permission + (spice-object resource-type resource-id))))) + +(defn datascript-lookup-resources + [db + {:as opts + :keys [spice-object->internal + cache-stamp + entid->object-id + object-id->lookup-ref + internal-cursor->spice + spice-cursor->internal]} + {:as query :keys [subject]}] + (let [internal-subject (spice-object->internal db subject)] + (assert (:id internal-subject) + (str "subject " (pr-str subject) + " passed to lookup-resources does not exist with lookup ref " + (object-id->lookup-ref (:id subject)))) + (->> query + (S/setval [:subject] internal-subject) + (S/transform [:cursor] + (fn [token-or-cursor] + (some->> (token->cursor token-or-cursor) + (spice-cursor->internal db opts)))) + (impl/lookup-resources db cache-stamp) + (S/transform [:data S/ALL] + (fn [{:keys [type id]}] + (spice-object type (entid->object-id db id)))) + (S/transform [:cursor] + (fn [internal-cursor] + (some->> (internal-cursor->spice db opts internal-cursor) + cursor->token)))))) + +(defn datascript-count-resources + [db + {:as opts + :keys [spice-object->internal + cache-stamp + spice-cursor->internal + internal-cursor->spice]} + {:as query :keys [subject]}] + (let [subject-ent (spice-object->internal db subject)] + (->> query + (S/setval [:subject] subject-ent) + (S/transform [:cursor] + (fn [token-or-cursor] + (some->> (token->cursor token-or-cursor) + (spice-cursor->internal db opts)))) + (impl/count-resources db cache-stamp) + (S/transform [:cursor] + (fn [internal-cursor] + (some->> (internal-cursor->spice db opts internal-cursor) + cursor->token)))))) + +(defn datascript-lookup-subjects + [db + {:as opts + :keys [entid->object-id + cache-stamp + spice-object->internal + spice-cursor->internal + internal-cursor->spice]} + query] + (->> query + (S/transform [:resource] #(spice-object->internal db %)) + (S/transform [:cursor] + (fn [token-or-cursor] + (some->> (token->cursor token-or-cursor) + (spice-cursor->internal db opts)))) + (impl/lookup-subjects db cache-stamp) + (S/transform [:data S/ALL] + (fn [{:keys [type id]}] + (spice-object type (entid->object-id db id)))) + (S/transform [:cursor] + (fn [internal-cursor] + (some->> (internal-cursor->spice db opts internal-cursor) + cursor->token))))) + +(defn datascript-count-subjects + [db + {:as opts + :keys [spice-object->internal + cache-stamp + spice-cursor->internal + internal-cursor->spice]} + query] + (->> query + (S/transform [:resource] #(spice-object->internal db %)) + (S/transform [:cursor] + (fn [token-or-cursor] + (some->> (token->cursor token-or-cursor) + (spice-cursor->internal db opts)))) + (impl/count-subjects db cache-stamp) + (S/transform [:cursor] + (fn [internal-cursor] + (some->> (internal-cursor->spice db opts internal-cursor) + cursor->token))))) + +(defrecord DataScriptAuthorization [conn opts] + IAuthorization + (can? [_ subject permission resource] + (datascript-can? (ds/db conn) opts subject permission resource consistency/fully-consistent)) + (can? [_ subject permission resource consistency] + (datascript-can? (ds/db conn) opts subject permission resource consistency)) + (can? [_ {:keys [subject permission resource consistency]}] + (datascript-can? (ds/db conn) opts subject permission resource + (or consistency consistency/fully-consistent))) + + (read-schema [_] + (schema/read-schema (ds/db conn))) + (write-schema! [_ schema-string] + (let [result (schema/write-schema! conn schema-string)] + (impl/evict-permission-paths-cache!) + result)) + + (read-relationships [_ filters] + (datascript-read-relationships (ds/db conn) opts filters)) + (write-relationships! [_ updates] + (datascript-write-relationships! conn opts updates)) + (write-relationship! [_ operation subject relation resource] + (datascript-write-relationships! conn opts + [(->RelationshipUpdate operation + (->Relationship subject relation resource))])) + (write-relationship! [_ {:as demand :keys [operation subject relation resource]}] + (datascript-write-relationships! conn opts + [(->RelationshipUpdate operation + (->Relationship subject relation resource))])) + (create-relationships! [_ relationships] + (datascript-write-relationships! conn opts + (for [rel relationships] + (->RelationshipUpdate :create rel)))) + (create-relationship! [_ relationship] + (datascript-write-relationships! conn opts + [(->RelationshipUpdate :create relationship)])) + (create-relationship! [_ subject relation resource] + (datascript-write-relationships! conn opts + [(->RelationshipUpdate :create (->Relationship subject relation resource))])) + (delete-relationships! [_ relationships] + (datascript-write-relationships! conn opts + (for [rel relationships] + (->RelationshipUpdate :delete rel)))) + (delete-relationship! [_ {:as relationship :keys [subject relation resource]}] + (datascript-write-relationships! conn opts + [(->RelationshipUpdate :delete + (->Relationship subject relation resource))])) + (delete-relationship! [_ subject relation resource] + (datascript-write-relationships! conn opts + [(->RelationshipUpdate :delete + (->Relationship subject relation resource))])) + + (lookup-resources [_ query] + (datascript-lookup-resources (ds/db conn) opts query)) + (count-resources [_ query] + (datascript-count-resources (ds/db conn) opts query)) + (lookup-subjects [_ query] + (datascript-lookup-subjects (ds/db conn) opts query)) + (count-subjects [_ query] + (datascript-count-subjects (ds/db conn) opts query)) + + (expand-permission-tree [_ _] + (throw (ex-info "not impl." {})))) + +(defonce stamp-registry (atom {})) + +(defn ensure-stamp! + [conn] + (if-let [state (get @stamp-registry conn)] + state + (let [state {:stamp (atom 0) + :listener-key (keyword (str "eacl-stamp-" (random-uuid)))}] + (ds/listen! conn + (:listener-key state) + (fn [_] (swap! (:stamp state) inc))) + (get (swap! stamp-registry + #(if (contains? % conn) % (assoc % conn state))) + conn)))) + +(defn make-client + [conn + {:keys [entity->object-id + object-id->lookup-ref + internal-cursor->spice + spice-cursor->internal] + :or {entity->object-id (fn [ent] (:eacl/id ent)) + object-id->lookup-ref (fn [obj-id] [:eacl/id obj-id]) + internal-cursor->spice default-internal-cursor->spice + spice-cursor->internal default-spice-cursor->internal}}] + (let [{:keys [stamp]} (ensure-stamp! conn) + object-id->entid (fn [db object-id] + (ds/entid db (object-id->lookup-ref object-id))) + entid->object-id (fn [db eid] + (entity->object-id (ds/entity db eid))) + opts {:object-id->lookup-ref object-id->lookup-ref + :cache-stamp (fn [] @stamp) + :stamp stamp + :entid->object-id entid->object-id + :entity->object-id entity->object-id + :object-id->entid object-id->entid + :object->entid (fn [db {:keys [id]}] + (object-id->entid db id)) + :internal-object->spice (fn [db {:keys [type id]}] + (spice-object type (entid->object-id db id))) + :spice-object->internal (fn [db obj] + (update obj :id #(object-id->entid db %))) + :internal-cursor->spice internal-cursor->spice + :spice-cursor->internal spice-cursor->internal}] + (->DataScriptAuthorization conn opts))) + +(defn create-conn + ([] (schema/create-conn)) + ([extra-schema] + (schema/create-conn extra-schema))) diff --git a/modules/eacl-datascript/src/eacl/datascript/impl.cljc b/modules/eacl-datascript/src/eacl/datascript/impl.cljc new file mode 100644 index 000000000..4952a7b63 --- /dev/null +++ b/modules/eacl-datascript/src/eacl/datascript/impl.cljc @@ -0,0 +1,283 @@ +(ns eacl.datascript.impl + (:require [datascript.core :as ds] + [eacl.core :as eacl :refer [spice-object]] + [eacl.engine.indexed :as engine] + [eacl.schema.model :as model] + [eacl.datascript.schema :as schema])) + +(def Relation model/Relation) +(def Permission model/Permission) + +(defn Relationship + [subject relation resource] + (eacl/->Relationship subject relation resource)) + +(def permission-paths-cache + (atom {})) + +(def max-entid + #?(:clj Long/MAX_VALUE + :cljs js/Number.MAX_SAFE_INTEGER)) + +(defn evict-permission-paths-cache! [] + (engine/evict-permission-paths-cache! permission-paths-cache)) + +(defn relation-datoms + [db resource-type relation-name] + (if (and resource-type relation-name) + (ds/index-range db + :eacl.relation/resource-type+relation-name+subject-type + [resource-type relation-name :a] + [resource-type relation-name :z]) + [])) + +(defn find-relation-def + [db resource-type relation-name] + (when-let [datom (first (relation-datoms db resource-type relation-name))] + (ds/pull db + '[:db/id + :eacl.relation/subject-type + :eacl.relation/resource-type + :eacl.relation/relation-name] + (:e datom)))) + +(defn find-permission-defs + [db resource-type permission-name] + (->> (ds/datoms db :avet :eacl.permission/resource-type+permission-name [resource-type permission-name]) + (map :e) + (map #(ds/pull db '[*] %)) + vec)) + +(defn subject->resources + [db subject-type subject-id relation-id resource-type cursor-resource-id] + (->> (ds/index-range db + schema/forward-relationship-attr + [subject-type subject-id relation-id resource-type (if cursor-resource-id (inc cursor-resource-id) 0)] + [subject-type subject-id relation-id resource-type max-entid]) + (map (fn [datom] (nth (:v datom) 4))))) + +(defn resource->subjects + [db resource-type resource-id relation-id subject-type cursor-subject-id] + (->> (ds/index-range db + schema/reverse-relationship-attr + [resource-type resource-id relation-id subject-type (if cursor-subject-id (inc cursor-subject-id) 0)] + [resource-type resource-id relation-id subject-type max-entid]) + (map (fn [datom] (nth (:v datom) 4))))) + +(defn- relationship-tuple + [{:keys [subject-type subject-id relation-id resource-type resource-id]}] + [subject-type subject-id relation-id resource-type resource-id]) + +(defn- relationship-reverse-tuple + [{:keys [resource-type resource-id relation-id subject-type subject-id]}] + [resource-type resource-id relation-id subject-type subject-id]) + +(defn- internal-id + [db value] + (when value + (ds/entid db value))) + +(defn- relation-id + [resource-type relation-name subject-type] + [:eacl/id (model/->relation-id resource-type relation-name subject-type)]) + +(defn- resolve-relationship + [db {:keys [subject relation resource]}] + (let [subject-type (:type subject) + subject-id (internal-id db (:id subject)) + resource-type (:type resource) + resource-id (internal-id db (:id resource)) + relation-eid (ds/entid db (relation-id resource-type relation subject-type))] + (when-not relation-eid + (throw + (ex-info + (str "Missing Relation: " relation + " on resource type " resource-type + " for subject type " subject-type ".") + {:resource/type resource-type + :relation/name relation + :subject/type subject-type}))) + {:subject subject + :subject-type subject-type + :subject-id subject-id + :relation relation + :relation-id relation-eid + :resource resource + :resource-type resource-type + :resource-id resource-id})) + +(defn find-one-relationship-id + [db relationship] + (let [resolved (resolve-relationship db relationship) + existing (ds/entid db [schema/relationship-full-key-attr + (relationship-tuple resolved)])] + (when existing + resolved))) + +(defn tx-update-relationship + [db {:keys [operation relationship]}] + (let [resolved (resolve-relationship db relationship) + tuple (relationship-tuple resolved) + existing (ds/entid db [schema/relationship-full-key-attr tuple])] + (case operation + :touch + (when-not existing + [{:eacl.relationship/subject-type (:subject-type resolved) + :eacl.relationship/subject (:subject-id resolved) + :eacl.relationship/relation (:relation-id resolved) + :eacl.relationship/resource-type (:resource-type resolved) + :eacl.relationship/resource (:resource-id resolved)}]) + + :create + (if existing + (throw (ex-info ":create relationship conflicts with existing tuple relationship" + {:relationship relationship})) + [{:eacl.relationship/subject-type (:subject-type resolved) + :eacl.relationship/subject (:subject-id resolved) + :eacl.relationship/relation (:relation-id resolved) + :eacl.relationship/resource-type (:resource-type resolved) + :eacl.relationship/resource (:resource-id resolved)}]) + + :delete + (when existing + [[:db/retractEntity existing]]) + + :unspecified + [{:eacl.relationship/subject-type (:subject-type resolved) + :eacl.relationship/subject (:subject-id resolved) + :eacl.relationship/relation (:relation-id resolved) + :eacl.relationship/resource-type (:resource-type resolved) + :eacl.relationship/resource (:resource-id resolved)}] + + (throw (ex-info "Unknown relationship operation" + {:operation operation}))))) + +(defn read-relationships + [db filters] + (->> (ds/datoms db :avet schema/forward-relationship-attr) + (map (fn [{:keys [v]}] + (let [[subject-type subject-id relation-id resource-type resource-id] v + rel-ent (ds/entity db relation-id)] + (eacl/->Relationship + (spice-object subject-type subject-id) + (:eacl.relation/relation-name rel-ent) + (spice-object resource-type resource-id))))) + (filter (fn [{:keys [subject relation resource]}] + (and (or (nil? (:subject/type filters)) + (= (:subject/type filters) (:type subject))) + (or (nil? (:subject/id filters)) + (= (:subject/id filters) (:id subject))) + (or (nil? (:resource/type filters)) + (= (:resource/type filters) (:type resource))) + (or (nil? (:resource/id filters)) + (= (:resource/id filters) (:id resource))) + (or (nil? (:resource/relation filters)) + (= (:resource/relation filters) relation))))))) + +(defn indexed-backend + ([db] + (indexed-backend db nil)) + ([db cache-stamp-fn] + {:cache-stamp (or cache-stamp-fn + (fn [] + (hash db))) + :relation-defs (fn [resource-type relation-name] + (mapv (fn [datom] + {:relation-id (:e datom) + :resource-type resource-type + :relation-name relation-name + :subject-type (nth (:v datom) 2)}) + (relation-datoms db resource-type relation-name))) + :permission-defs (fn [resource-type permission-name] + (mapv (fn [perm] + {:permission-id (:db/id perm) + :resource-type (:eacl.permission/resource-type perm) + :permission-name (:eacl.permission/permission-name perm) + :source-relation-name (:eacl.permission/source-relation-name perm) + :target-type (:eacl.permission/target-type perm) + :target-name (:eacl.permission/target-name perm)}) + (find-permission-defs db resource-type permission-name))) + :subject->resources (fn [subject-type subject-id relation-id resource-type cursor-resource-id] + (subject->resources db subject-type subject-id relation-id resource-type cursor-resource-id)) + :resource->subjects (fn [resource-type resource-id relation-id subject-type cursor-subject-id] + (resource->subjects db resource-type resource-id relation-id subject-type cursor-subject-id)) + :direct-match? (fn [subject-type subject-id relation-id resource-type resource-id] + (boolean + (ds/entid db [schema/relationship-full-key-attr + [subject-type subject-id relation-id resource-type resource-id]])))})) + +(defn- backend* + [db-or-backend] + (if (and (map? db-or-backend) (contains? db-or-backend :cache-stamp)) + db-or-backend + (indexed-backend db-or-backend))) + +(defn calc-permission-paths + ([db-or-backend resource-type permission-name] + (engine/calc-permission-paths (backend* db-or-backend) resource-type permission-name)) + ([db-or-backend resource-type permission-name visited-perms] + (engine/calc-permission-paths (backend* db-or-backend) resource-type permission-name visited-perms))) + +(defn get-permission-paths + [db-or-backend resource-type permission-name] + (let [backend (backend* db-or-backend)] + (engine/get-permission-paths permission-paths-cache calc-permission-paths backend resource-type permission-name))) + +(defn can? + ([db subject permission resource] + (can? db nil subject permission resource)) + ([db cache-stamp-fn subject permission resource] + (let [subject-id (internal-id db (:id subject)) + resource-id (internal-id db (:id resource))] + (engine/can? + (indexed-backend db cache-stamp-fn) + get-permission-paths + (assoc subject :id subject-id) + permission + (assoc resource :id resource-id))))) + +(defn- internalize-anchor + [db object] + (update object :id #(internal-id db %))) + +(defn lookup-resources + ([db query] + (lookup-resources db nil query)) + ([db cache-stamp-fn query] + (engine/lookup + (indexed-backend db cache-stamp-fn) + engine/forward-direction + get-permission-paths + (update query :subject #(internalize-anchor db %))))) + +(defn lookup-subjects + ([db query] + (lookup-subjects db nil query)) + ([db cache-stamp-fn query] + (engine/lookup + (indexed-backend db cache-stamp-fn) + engine/reverse-direction + get-permission-paths + (update query :resource #(internalize-anchor db %))))) + +(defn count-resources + ([db query] + (count-resources db nil query)) + ([db cache-stamp-fn query] + (engine/count-results + (indexed-backend db cache-stamp-fn) + engine/forward-direction + get-permission-paths + (update query :subject #(internalize-anchor db %)) + :resource))) + +(defn count-subjects + ([db query] + (count-subjects db nil query)) + ([db cache-stamp-fn query] + (engine/count-results + (indexed-backend db cache-stamp-fn) + engine/reverse-direction + get-permission-paths + (update query :resource #(internalize-anchor db %)) + :subject))) diff --git a/modules/eacl-datascript/src/eacl/datascript/schema.cljc b/modules/eacl-datascript/src/eacl/datascript/schema.cljc new file mode 100644 index 000000000..4b04d8e3c --- /dev/null +++ b/modules/eacl-datascript/src/eacl/datascript/schema.cljc @@ -0,0 +1,159 @@ +(ns eacl.datascript.schema + (:require [datascript.core :as ds] + [eacl.schema.model :as model] + [eacl.spicedb.parser :as parser])) + +(def forward-relationship-attr + :eacl.v7.relationship/subject-type+subject+relation+resource-type+resource) + +(def reverse-relationship-attr + :eacl.v7.relationship/resource-type+resource+relation+subject-type+subject) + +(def relationship-full-key-attr + :eacl.relationship/full-key) + +(def max-entid + #?(:clj Long/MAX_VALUE + :cljs js/Number.MAX_SAFE_INTEGER)) + +(def datascript-schema + {:eacl/id {:db/unique :db.unique/identity} + :eacl.relation/resource-type {:db/index true} + :eacl.relation/relation-name {:db/index true} + :eacl.relation/subject-type {:db/index true} + :eacl.relation/resource-type+relation-name+subject-type + {:db/valueType :db.type/tuple + :db/tupleAttrs [:eacl.relation/resource-type + :eacl.relation/relation-name + :eacl.relation/subject-type] + :db/unique :db.unique/identity} + + :eacl.permission/resource-type {:db/index true} + :eacl.permission/permission-name {:db/index true} + :eacl.permission/source-relation-name {:db/index true} + :eacl.permission/target-type {:db/index true} + :eacl.permission/target-name {:db/index true} + :eacl.permission/resource-type+permission-name + {:db/valueType :db.type/tuple + :db/tupleAttrs [:eacl.permission/resource-type + :eacl.permission/permission-name] + :db/index true} + :eacl.permission/full-key + {:db/valueType :db.type/tuple + :db/tupleAttrs [:eacl.permission/resource-type + :eacl.permission/source-relation-name + :eacl.permission/target-type + :eacl.permission/target-name + :eacl.permission/permission-name] + :db/unique :db.unique/identity} + + :eacl.relationship/subject {:db/valueType :db.type/ref} + :eacl.relationship/relation {:db/valueType :db.type/ref} + :eacl.relationship/resource {:db/valueType :db.type/ref} + :eacl.relationship/subject-type {:db/index true} + :eacl.relationship/resource-type {:db/index true} + :eacl.relationship/full-key + {:db/valueType :db.type/tuple + :db/tupleAttrs [:eacl.relationship/subject-type + :eacl.relationship/subject + :eacl.relationship/relation + :eacl.relationship/resource-type + :eacl.relationship/resource] + :db/unique :db.unique/identity} + :eacl.v7.relationship/subject-type+subject+relation+resource-type+resource + {:db/valueType :db.type/tuple + :db/tupleAttrs [:eacl.relationship/subject-type + :eacl.relationship/subject + :eacl.relationship/relation + :eacl.relationship/resource-type + :eacl.relationship/resource] + :db/index true} + :eacl.v7.relationship/resource-type+resource+relation+subject-type+subject + {:db/valueType :db.type/tuple + :db/tupleAttrs [:eacl.relationship/resource-type + :eacl.relationship/resource + :eacl.relationship/relation + :eacl.relationship/subject-type + :eacl.relationship/subject] + :db/index true}}) + +(defn merge-schema + ([] datascript-schema) + ([extra-schema] + (merge datascript-schema extra-schema))) + +(defn create-conn + ([] (create-conn nil)) + ([extra-schema] + (ds/create-conn (merge-schema extra-schema)))) + +(defn read-relations + [db] + (ds/q '[:find [(pull ?relation [:eacl/id + :eacl.relation/subject-type + :eacl.relation/resource-type + :eacl.relation/relation-name]) ...] + :where + [?relation :eacl.relation/relation-name]] + db)) + +(defn read-permissions + [db] + (ds/q '[:find [(pull ?perm [:eacl/id + :eacl.permission/resource-type + :eacl.permission/permission-name + :eacl.permission/source-relation-name + :eacl.permission/target-type + :eacl.permission/target-name]) ...] + :where + [?perm :eacl.permission/permission-name]] + db)) + +(defn read-schema + [db & [_format]] + {:relations (read-relations db) + :permissions (read-permissions db)}) + +(def validate-schema-references model/validate-schema-references) +(def calc-set-deltas model/calc-set-deltas) +(def compare-schema model/compare-schema) + +(defn count-relationships-using-relation + [db {:eacl.relation/keys [resource-type relation-name subject-type]}] + (let [relation-id (str "eacl.relation:" resource-type ":" relation-name ":" subject-type) + relation-eid (ds/entid db [:eacl/id relation-id])] + (if-not relation-eid + 0 + (count + (ds/index-range db + forward-relationship-attr + [subject-type 0 relation-eid resource-type 0] + [subject-type max-entid relation-eid resource-type max-entid]))))) + +(defn write-schema! + [conn schema-string] + (let [new-schema-map (parser/->eacl-schema (parser/parse-schema schema-string)) + _ (validate-schema-references new-schema-map) + db (ds/db conn) + existing-schema (read-schema db) + deltas (compare-schema existing-schema new-schema-map) + {:keys [relations permissions]} deltas + relation-retractions (:retractions relations) + permission-retractions (:retractions permissions)] + (doseq [rel relation-retractions] + (let [cnt (count-relationships-using-relation db rel)] + (when (pos? cnt) + (throw (ex-info (str "Cannot delete relation " (:eacl.relation/relation-name rel) + " because it is used by " cnt " relationships.") + {:relation rel :count cnt}))))) + (ds/transact! conn + (concat + (:additions relations) + (:additions permissions) + (for [rel relation-retractions] + [:db/retractEntity [:eacl/id (:eacl/id rel)]]) + (for [perm permission-retractions] + [:db/retractEntity [:eacl/id (:eacl/id perm)]]) + [{:eacl/id "schema-string" + :eacl/schema-string schema-string}])) + deltas)) diff --git a/modules/eacl-datascript/test/eacl/datascript/cljs_test_runner.cljs b/modules/eacl-datascript/test/eacl/datascript/cljs_test_runner.cljs new file mode 100644 index 000000000..5e897d677 --- /dev/null +++ b/modules/eacl-datascript/test/eacl/datascript/cljs_test_runner.cljs @@ -0,0 +1,20 @@ +(ns eacl.datascript.cljs-test-runner + (:require [cljs.nodejs :as nodejs] + [cljs.test :as t] + [eacl.datascript.contract-test])) + +(nodejs/enable-util-print!) + +(defmethod t/report [::t/default :end-run-tests] [m] + (let [failures (+ (:fail m 0) (:error m 0))] + (.log js/console + (str "EACL DataScript CLJS tests complete. failures=" + (:fail m 0) + " errors=" + (:error m 0))) + (js/process.exit failures))) + +(defn -main [] + (t/run-tests 'eacl.datascript.contract-test)) + +(set! *main-cli-fn* -main) diff --git a/modules/eacl-datascript/test/eacl/datascript/contract_test.cljc b/modules/eacl-datascript/test/eacl/datascript/contract_test.cljc new file mode 100644 index 000000000..ffaaeb8e3 --- /dev/null +++ b/modules/eacl-datascript/test/eacl/datascript/contract_test.cljc @@ -0,0 +1,22 @@ +(ns eacl.datascript.contract-test + (:require [#?(:clj clojure.test :cljs cljs.test) :refer [deftest]] + [datascript.core :as ds] + [eacl.contract-support :as contract] + [eacl.core :as eacl] + [eacl.datascript.core :as datascript])) + +(defn- seed-objects! + [conn] + (ds/transact! conn + (map-indexed (fn [idx {:keys [id]}] + {:db/id (- (inc idx)) + :eacl/id id}) + contract/smoke-objects))) + +(deftest datascript-contract-test + (let [conn (datascript/create-conn) + client (datascript/make-client conn {})] + (eacl/write-schema! client contract/smoke-schema) + (seed-objects! conn) + (eacl/create-relationships! client contract/smoke-relationships) + (contract/assert-seeded-contracts! client))) diff --git a/modules/eacl-datomic/README.md b/modules/eacl-datomic/README.md new file mode 100644 index 000000000..1d6761e20 --- /dev/null +++ b/modules/eacl-datomic/README.md @@ -0,0 +1,11 @@ +# `eacl-datomic` + +Datomic adapter for EACL. + +Responsibilities: + +- Datomic physical schema and schema installation +- Datomic tuple/index storage implementation +- Datomic relationship write planning and transaction execution +- Datomic compatibility namespaces preserving the existing public surface +- Datomic-only regression and storage-mechanics tests diff --git a/modules/eacl-datomic/build.clj b/modules/eacl-datomic/build.clj new file mode 100644 index 000000000..04ca2cdb7 --- /dev/null +++ b/modules/eacl-datomic/build.clj @@ -0,0 +1,38 @@ +(ns build + (:require [clojure.tools.build.api :as b])) + +(def module-dir "modules/eacl-datomic") +(def lib 'cloudafrica/eacl-datomic) +(def version "0.0.1-SNAPSHOT") +(def class-dir (str module-dir "/target/classes")) +(def jar-file (format "%s/target/%s-%s.jar" module-dir (name lib) version)) +(def pom-basis + {:libs {'org.clojure/clojure {:mvn/version "1.12.0-alpha5"} + 'cloudafrica/eacl {:mvn/version version} + 'com.rpl/specter {:mvn/version "1.1.4"} + 'com.datomic/peer {:mvn/version "1.0.6733"} + 'org.clojure/tools.logging {:mvn/version "1.3.0"}}}) + +(defn clean [_] + (b/delete {:path (str module-dir "/target")})) + +(defn jar [_] + (clean nil) + (b/write-pom {:class-dir class-dir + :lib lib + :version version + :basis pom-basis + :src-dirs [(str module-dir "/src")]}) + (b/copy-dir {:src-dirs [(str module-dir "/src") + (str module-dir "/resources")] + :target-dir class-dir}) + (b/jar {:class-dir class-dir + :jar-file jar-file})) + +(defn install [_] + (jar nil) + (b/install {:class-dir class-dir + :jar-file jar-file + :lib lib + :version version + :basis pom-basis})) diff --git a/modules/eacl-datomic/deps.edn b/modules/eacl-datomic/deps.edn new file mode 100644 index 000000000..84a7c82fa --- /dev/null +++ b/modules/eacl-datomic/deps.edn @@ -0,0 +1,12 @@ +{:paths ["src" "resources"] + :deps {org.clojure/clojure {:mvn/version "1.12.0-alpha5"} + cloudafrica/eacl {:local/root "../eacl"} + com.rpl/specter {:mvn/version "1.1.4"} + com.datomic/peer {:mvn/version "1.0.6733"} + org.clojure/tools.logging {:mvn/version "1.3.0"}} + :aliases {:test {:extra-paths ["test"] + :extra-deps {io.github.cognitect-labs/test-runner {:git/tag "v0.5.1" :git/sha "dfb30dd"} + criterium/criterium {:mvn/version "0.4.6"}}} + :nrepl {:extra-paths ["test"] + :extra-deps {nrepl/nrepl {:mvn/version "1.3.1"}} + :main-opts ["-m" "nrepl.cmdline"]}}} diff --git a/modules/eacl-datomic/src/eacl/datomic/core.clj b/modules/eacl-datomic/src/eacl/datomic/core.clj new file mode 100644 index 000000000..3bba4245e --- /dev/null +++ b/modules/eacl-datomic/src/eacl/datomic/core.clj @@ -0,0 +1,310 @@ +(ns eacl.datomic.core + "Reifies eacl.core/IAuthorization for Datomic-backed EACL in eacl.datomic.impl." + (:require [clojure.tools.logging :as log] + [com.rpl.specter :as S] + [datomic.api :as d] + [eacl.cursor :as cursor] + [eacl.core :as eacl :refer [IAuthorization + spice-object + ->Relationship + ->RelationshipUpdate + map->Relationship]] + [eacl.datomic.impl :as impl] + [eacl.datomic.schema :as schema] + [eacl.spicedb.consistency :as consistency] + [malli.core :as m])) + +(def cursor->token cursor/cursor->token) +(def token->cursor cursor/token->cursor) + +(defn default-internal-cursor->spice + [db {:keys [entid->object-id]} cursor] + (when cursor + (if (= 2 (:v cursor)) + (cond-> cursor + (:e cursor) (update :e #(entid->object-id db %)) + (:p cursor) (update :p + (fn [p] + (into {} + (map (fn [[k v]] [k (entid->object-id db v)])) + p)))) + (cond + (:resource cursor) (S/transform [:resource :id] #(entid->object-id db %) cursor) + (:subject cursor) (S/transform [:subject :id] #(entid->object-id db %) cursor))))) + +(defn default-spice-cursor->internal + [db {:keys [object-id->entid]} cursor] + (when cursor + (if (= 2 (:v cursor)) + (cond-> cursor + (:e cursor) (update :e #(object-id->entid db %)) + (:p cursor) (update :p + (fn [p] + (into {} + (map (fn [[k v]] [k (object-id->entid db v)])) + p)))) + (cond + (:resource cursor) (S/transform [:resource :id] #(object-id->entid db %) cursor) + (:subject cursor) (S/transform [:subject :id] #(object-id->entid db %) cursor))))) + +(defn object->spice + [db {:keys [entid->object-id]} object] + (update object :id #(entid->object-id db %))) + +(defn relationship->spice + [db opts {:keys [subject relation resource]}] + (map->Relationship + {:subject (object->spice db opts subject) + :relation relation + :resource (object->spice db opts resource)})) + +(defn spiceomic-read-relationships + [db + {:keys [object-id->entid] :as opts} + filters] + (let [subject-id (:subject/id filters) + resource-id (:resource/id filters) + subject-eid (when subject-id (object-id->entid db subject-id)) + resource-eid (when resource-id (object-id->entid db resource-id)) + filters' (cond-> filters + subject-id (assoc :subject/id subject-eid) + resource-id (assoc :resource/id resource-eid))] + (->> (impl/read-relationships db filters') + (map #(relationship->spice db opts %))))) + +(defn spice-relationship->internal + [db {:keys [spice-object->internal]} {:keys [subject relation resource]}] + {:subject (spice-object->internal db subject) + :relation relation + :resource (spice-object->internal db resource)}) + +(defn spiceomic-write-relationships! + [conn opts updates] + (let [db (d/db conn) + tx-data (->> updates + (S/transform [S/ALL :relationship] + #(spice-relationship->internal db opts %)) + (mapcat #(impl/tx-update-relationship db %)) + (remove nil?)) + {:keys [db-after]} @(d/transact conn tx-data) + basis (d/basis-t db-after)] + {:zed/token (str basis)})) + +(defn spiceomic-can? + [db {:keys [object->entid]} subject permission resource consistency] + (assert (= consistency/fully-consistent consistency) + "EACL only supports consistency/fully-consistent at this time.") + (let [subject-type (:type subject) + subject-eid (object->entid db subject) + resource-type (:type resource) + resource-eid (object->entid db resource)] + (if-not (and subject-eid resource-eid) + false + (impl/can? db + (spice-object subject-type subject-eid) + permission + (spice-object resource-type resource-eid))))) + +(defn spiceomic-lookup-resources + [db + {:as opts + :keys [spice-object->internal + entid->object-id + object-id->ident + internal-cursor->spice + spice-cursor->internal]} + {:as query :keys [subject]}] + (log/debug 'spiceomic-lookup-resources 'query query) + (let [internal-subject (spice-object->internal db subject)] + (assert (:id internal-subject) + (str "subject " (pr-str subject) + " passed to lookup-resources does not exist with ident " + (object-id->ident (:id subject)))) + (->> query + (S/setval [:subject] internal-subject) + (S/transform [:cursor] + (fn [token-or-cursor] + (some->> (token->cursor token-or-cursor) + (spice-cursor->internal db opts)))) + (impl/lookup-resources db) + (S/transform [:data S/ALL] + (fn [{:keys [type id]}] + (spice-object type (entid->object-id db id)))) + (S/transform [:cursor] + (fn [internal-cursor] + (some->> (internal-cursor->spice db opts internal-cursor) + cursor->token)))))) + +(defn spiceomic-count-resources + [db + {:as opts + :keys [spice-object->internal + spice-cursor->internal + internal-cursor->spice]} + {:as query :keys [subject]}] + (let [subject-ent (spice-object->internal db subject)] + (assert (:id subject-ent) + (str "subject passed to count-resources does not exist: " (pr-str subject))) + (assert (= (:type subject-ent) (:type subject)) + (str "count-resources: subject type passed does not match entity: " + (pr-str subject))) + (->> query + (S/setval [:subject] subject-ent) + (S/transform [:cursor] + (fn [token-or-cursor] + (some->> (token->cursor token-or-cursor) + (spice-cursor->internal db opts)))) + (impl/count-resources db) + (S/transform [:cursor] + (fn [internal-cursor] + (some->> (internal-cursor->spice db opts internal-cursor) + cursor->token)))))) + +(defn spiceomic-lookup-subjects + [db + {:as opts + :keys [entid->object-id + spice-object->internal + spice-cursor->internal + internal-cursor->spice]} + query] + (->> query + (S/transform [:resource] #(spice-object->internal db %)) + (S/transform [:cursor] + (fn [token-or-cursor] + (some->> (token->cursor token-or-cursor) + (spice-cursor->internal db opts)))) + (impl/lookup-subjects db) + (S/transform [:data S/ALL] + (fn [{:keys [type id]}] + (spice-object type (entid->object-id db id)))) + (S/transform [:cursor] + (fn [internal-cursor] + (some->> (internal-cursor->spice db opts internal-cursor) + cursor->token))))) + +(defn spiceomic-count-subjects + [db + {:as opts + :keys [spice-object->internal + spice-cursor->internal + internal-cursor->spice]} + query] + (->> query + (S/transform [:resource] #(spice-object->internal db %)) + (S/transform [:cursor] + (fn [token-or-cursor] + (some->> (token->cursor token-or-cursor) + (spice-cursor->internal db opts)))) + (impl/count-subjects db) + (S/transform [:cursor] + (fn [internal-cursor] + (some->> (internal-cursor->spice db opts internal-cursor) + cursor->token))))) + +(defrecord Spiceomic [conn opts] + IAuthorization + (can? [_ subject permission resource] + (spiceomic-can? (d/db conn) opts subject permission resource consistency/fully-consistent)) + + (can? [_ subject permission resource consistency] + (spiceomic-can? (d/db conn) opts subject permission resource consistency)) + + (can? [_ {:keys [subject permission resource consistency]}] + (spiceomic-can? (d/db conn) opts subject permission resource + (or consistency consistency/fully-consistent))) + + (read-schema [_] + (schema/read-schema (d/db conn))) + + (write-schema! [_ schema-string] + (schema/write-schema! conn schema-string)) + + (read-relationships [_ filters] + (spiceomic-read-relationships (d/db conn) opts filters)) + + (write-relationships! [_ updates] + (spiceomic-write-relationships! conn opts updates)) + + (write-relationship! [_ operation subject relation resource] + (spiceomic-write-relationships! conn opts + [(->RelationshipUpdate operation + (->Relationship subject relation resource))])) + + (write-relationship! [_ {:as demand :keys [operation subject relation resource]}] + (spiceomic-write-relationships! conn opts + [(->RelationshipUpdate operation + (->Relationship subject relation resource))])) + + (create-relationships! [_ relationships] + (spiceomic-write-relationships! conn opts + (for [rel relationships] + (->RelationshipUpdate :create rel)))) + + (create-relationship! [_ relationship] + (spiceomic-write-relationships! conn opts + [(->RelationshipUpdate :create relationship)])) + + (create-relationship! [_ subject relation resource] + (spiceomic-write-relationships! conn opts + [(->RelationshipUpdate :create (->Relationship subject relation resource))])) + + (delete-relationships! [_ relationships] + (spiceomic-write-relationships! conn opts + (for [rel relationships] + (->RelationshipUpdate :delete rel)))) + + (delete-relationship! [_ {:as relationship :keys [subject relation resource]}] + (spiceomic-write-relationships! conn opts + [(->RelationshipUpdate :delete + (->Relationship subject relation resource))])) + + (delete-relationship! [_ subject relation resource] + (spiceomic-write-relationships! conn opts + [(->RelationshipUpdate :delete + (->Relationship subject relation resource))])) + + (lookup-resources [_ query] + (spiceomic-lookup-resources (d/db conn) opts query)) + + (count-resources [_ query] + (spiceomic-count-resources (d/db conn) opts query)) + + (lookup-subjects [_ query] + (spiceomic-lookup-subjects (d/db conn) opts query)) + + (count-subjects [_ query] + (spiceomic-count-subjects (d/db conn) opts query)) + + (expand-permission-tree [_ _] + (throw (Exception. "not impl.")))) + +(defn make-client + [conn + {:keys [entity->object-id + object-id->ident + internal-cursor->spice + spice-cursor->internal] + :or {entity->object-id (fn [ent] (:eacl/id ent)) + object-id->ident (fn [obj-id] [:eacl/id obj-id]) + internal-cursor->spice default-internal-cursor->spice + spice-cursor->internal default-spice-cursor->internal}}] + (assert (fn? object-id->ident) + "EACL Config Error: object-id->ident fn is required to coerce a Spice Object ID to a Datomic ident that can be resolved by d/entid.") + (let [object-id->entid (fn [db object-id] + (d/entid db (object-id->ident object-id))) + entid->object-id (fn [db eid] + (entity->object-id (d/entity db eid))) + opts {:object-id->ident object-id->ident + :entid->object-id entid->object-id + :entity->object-id entity->object-id + :object-id->entid object-id->entid + :object->entid (fn [db {:keys [id]}] + (object-id->entid db id)) + :internal-object->spice (fn [db {:keys [type id]}] + (spice-object type (entid->object-id db id))) + :spice-object->internal (fn [db obj] + (update obj :id #(object-id->entid db %))) + :internal-cursor->spice internal-cursor->spice + :spice-cursor->internal spice-cursor->internal}] + (->Spiceomic conn opts))) diff --git a/modules/eacl-datomic/src/eacl/datomic/impl.clj b/modules/eacl-datomic/src/eacl/datomic/impl.clj new file mode 100644 index 000000000..bb8da36d2 --- /dev/null +++ b/modules/eacl-datomic/src/eacl/datomic/impl.clj @@ -0,0 +1,266 @@ +(ns eacl.datomic.impl + "EACL: Enterprise Access Control. Spice-compatible authorization system in Datomic." + (:require + [datomic.api :as d] + [eacl.core :as eacl :refer [spice-object]] + [eacl.datomic.impl.base :as base] + [eacl.datomic.impl.indexed :as impl.indexed])) + +(def Relation base/Relation) +(def Permission base/Permission) + +(defn Relationship + "Constructs relationship data for the public/internal API boundary. + Persistence is handled by tuple-specific write helpers below." + [subject relation resource] + (eacl/->Relationship subject relation resource)) + +(def can? impl.indexed/can?) +(def lookup-subjects impl.indexed/lookup-subjects) +(def lookup-resources impl.indexed/lookup-resources) +(def count-resources impl.indexed/count-resources) +(def count-subjects impl.indexed/count-subjects) + +(def ^:private forward-relationship-attr + :eacl.v7.relationship/subject-type+relation+resource-type+resource) + +(def ^:private reverse-relationship-attr + :eacl.v7.relationship/resource-type+relation+subject-type+subject) + +(defn can! + "The thrown exception should probably be configurable." + [db subject permission resource] + (if (can? db subject permission resource) + true + (throw (Exception. "Unauthorized")))) + +(defn- object-id->eid-or-tempid + [db object-id] + (cond + (number? object-id) object-id + (string? object-id) (or (d/entid db [:eacl/id object-id]) object-id) + :else (or (d/entid db object-id) object-id))) + +(defn- find-relation-eid + [db resource-type relation-name subject-type] + (d/q '[:find ?relation . + :in $ ?resource-type ?relation-name ?subject-type + :where + [?relation :eacl.relation/resource-type ?resource-type] + [?relation :eacl.relation/relation-name ?relation-name] + [?relation :eacl.relation/subject-type ?subject-type]] + db resource-type relation-name subject-type)) + +(defn- resolve-relationship + [db {:keys [subject relation resource]}] + (let [subject-type (:type subject) + subject-eid (object-id->eid-or-tempid db (:id subject)) + resource-type (:type resource) + resource-eid (object-id->eid-or-tempid db (:id resource)) + relation-eid (find-relation-eid db resource-type relation subject-type)] + (when-not relation-eid + (throw + (ex-info + (str "Missing Relation: " relation + " on resource type " resource-type + " for subject type " subject-type ".") + {:resource/type resource-type + :relation/name relation + :subject/type subject-type}))) + {:subject subject + :subject-type subject-type + :subject-eid subject-eid + :relation relation + :relation-eid relation-eid + :resource resource + :resource-type resource-type + :resource-eid resource-eid})) + +(defn- relationship-tuple + [{:keys [subject-type relation-eid resource-type resource-eid]}] + [subject-type relation-eid resource-type resource-eid]) + +(defn- reverse-relationship-tuple + [{:keys [resource-type relation-eid subject-type subject-eid]}] + [resource-type relation-eid subject-type subject-eid]) + +(defn- add-relationship-txes + [resolved] + [[:db/add (:subject-eid resolved) + forward-relationship-attr + (relationship-tuple resolved)] + [:db/add (:resource-eid resolved) + reverse-relationship-attr + (reverse-relationship-tuple resolved)]]) + +(defn- retract-relationship-txes + [resolved] + [[:db/retract (:subject-eid resolved) + forward-relationship-attr + (relationship-tuple resolved)] + [:db/retract (:resource-eid resolved) + reverse-relationship-attr + (reverse-relationship-tuple resolved)]]) + +(defn- relationship-exists? + [db {:keys [subject-eid resource-eid] :as resolved}] + (if (and (number? subject-eid) (number? resource-eid)) + (boolean + (seq + (d/datoms db + :eavt + subject-eid + forward-relationship-attr + (relationship-tuple resolved)))) + false)) + +(defn find-one-relationship-id + "Returns the resolved tuple identity for an existing relationship, or nil." + [db relationship] + (let [resolved (resolve-relationship db relationship)] + (when (relationship-exists? db resolved) + resolved))) + +(defn- find-relations + [db filters] + (let [resource-type (:resource/type filters) + resource-relation (:resource/relation filters) + subject-type (:subject/type filters)] + (->> (d/q '[:find [(pull ?relation [:db/id + :eacl.relation/resource-type + :eacl.relation/relation-name + :eacl.relation/subject-type]) ...] + :where + [?relation :eacl.relation/relation-name ?relation-name]] + db) + (filter (fn [relation] + (and (or (nil? resource-type) + (= resource-type (:eacl.relation/resource-type relation))) + (or (nil? resource-relation) + (= resource-relation (:eacl.relation/relation-name relation))) + (or (nil? subject-type) + (= subject-type (:eacl.relation/subject-type relation))))))))) + +(defn- decode-forward-datom + [db relation-by-eid subject-eid [_subject-type relation-eid resource-type resource-eid]] + (let [relation-name (or (get relation-by-eid relation-eid) + (:eacl.relation/relation-name (d/entity db relation-eid))) + subject-type (:eacl.relation/subject-type (d/entity db relation-eid))] + (eacl/->Relationship + (spice-object subject-type subject-eid) + relation-name + (spice-object resource-type resource-eid)))) + +(defn- scan-subject-relationships + [db relations subject-eid] + (->> relations + (mapcat + (fn [{:db/keys [id] + :eacl.relation/keys [resource-type relation-name subject-type]}] + (->> (impl.indexed/subject->resources db subject-type subject-eid id resource-type nil) + (map #(eacl/->Relationship + (spice-object subject-type subject-eid) + relation-name + (spice-object resource-type %)))))) + seq)) + +(defn- scan-resource-relationships + [db relations resource-eid] + (->> relations + (mapcat + (fn [{:db/keys [id] + :eacl.relation/keys [resource-type relation-name subject-type]}] + (->> (impl.indexed/resource->subjects db resource-type resource-eid id subject-type nil) + (map #(eacl/->Relationship + (spice-object subject-type %) + relation-name + (spice-object resource-type resource-eid)))))) + seq)) + +(defn- scan-global-relationships + [db relations] + (let [relation-by-eid (into {} + (map (juxt :db/id :eacl.relation/relation-name)) + relations)] + (->> relations + (mapcat + (fn [{:db/keys [id] + :eacl.relation/keys [resource-type subject-type]}] + (let [start [subject-type id resource-type 0] + end [subject-type id resource-type Long/MAX_VALUE]] + (->> (d/index-range db forward-relationship-attr start end) + (map (fn [datom] + (decode-forward-datom db relation-by-eid (:e datom) (:v datom)))))))) + seq))) + +(defn- relationship-matches-filters? + [filters {:keys [subject relation resource]}] + (and (or (nil? (:subject/type filters)) + (= (:subject/type filters) (:type subject))) + (or (nil? (:subject/id filters)) + (= (:subject/id filters) (:id subject))) + (or (nil? (:resource/type filters)) + (= (:resource/type filters) (:type resource))) + (or (nil? (:resource/id filters)) + (= (:resource/id filters) (:id resource))) + (or (nil? (:resource/relation filters)) + (= (:resource/relation filters) relation)))) + +(defn read-relationships + [db filters] + (let [relations (find-relations db filters) + subject-id (:subject/id filters) + resource-id (:resource/id filters) + subject-eid (when subject-id (d/entid db subject-id)) + resource-eid (when resource-id (d/entid db resource-id)) + normalized-filters (cond-> filters + subject-eid (assoc :subject/id subject-eid) + resource-eid (assoc :resource/id resource-eid))] + (->> (cond + (and subject-id (nil? subject-eid)) + (throw (ex-info "read-relationships is missing a valid :subject/id." + {:subject/id subject-id})) + + (and resource-id (nil? resource-eid)) + (throw (ex-info "read-relationships is missing a valid :resource/id." + {:resource/id resource-id})) + + subject-eid + (scan-subject-relationships db relations subject-eid) + + resource-eid + (scan-resource-relationships db relations resource-eid) + + :else + (scan-global-relationships db relations)) + (filter #(relationship-matches-filters? normalized-filters %))))) + +(defn tx-relationship + "Translate relationship data into v7 tuple writes." + ([db subject relation resource] + (tx-relationship db (eacl/->Relationship subject relation resource))) + ([db relationship] + (add-relationship-txes (resolve-relationship db relationship)))) + +(defn tx-update-relationship + "Relationship writes are implemented against v7 forward/reverse tuple indexes. + :touch is idempotent." + [db {:keys [operation relationship]}] + (let [resolved (resolve-relationship db relationship) + exists? (relationship-exists? db resolved)] + (case operation + :touch + (when-not exists? + (add-relationship-txes resolved)) + + :create + (if exists? + (throw (Exception. ":create relationship conflicts with existing tuple relationship")) + (add-relationship-txes resolved)) + + :delete + (when exists? + (retract-relationship-txes resolved)) + + :unspecified + (throw (Exception. ":unspecified relationship update not supported."))))) diff --git a/modules/eacl-datomic/src/eacl/datomic/impl/base.clj b/modules/eacl-datomic/src/eacl/datomic/impl/base.clj new file mode 100644 index 000000000..f4944d9f3 --- /dev/null +++ b/modules/eacl-datomic/src/eacl/datomic/impl/base.clj @@ -0,0 +1,25 @@ +(ns eacl.datomic.impl.base + "EACL: Enterprise Access Control. Spice-compatible authorization system in Datomic." + (:require [eacl.schema.model :as model])) + +(defrecord Cursor [path-index resource]) + +(def ->relation-id model/->relation-id) +(def Relation model/Relation) +(def ->permission-id model/->permission-id) +(def Permission model/Permission) + +(defn Relationship + "A Relationship between a subject and a resource via Relation. Copied from core2." + [subject relation-name resource] + ; :pre can be expensive. + {:pre [(:id subject) + (:type subject) + (keyword? relation-name) + (:id resource) + (:type resource)]} + {:eacl.relationship/resource-type (:type resource) + :eacl.relationship/resource (:id resource) + :eacl.relationship/relation-name relation-name + :eacl.relationship/subject-type (:type subject) + :eacl.relationship/subject (:id subject)}) diff --git a/modules/eacl-datomic/src/eacl/datomic/impl/datalog.clj b/modules/eacl-datomic/src/eacl/datomic/impl/datalog.clj new file mode 100644 index 000000000..128fbcf10 --- /dev/null +++ b/modules/eacl-datomic/src/eacl/datomic/impl/datalog.clj @@ -0,0 +1,153 @@ +(ns eacl.datomic.impl.datalog + "Optimized EACL implementation with performance improvements" + (:require + [datomic.api :as d] + [eacl.core :as proto :refer [spice-object]] + ;[eacl.datomic.impl.base :as base] + [eacl.datomic.rules.optimized :as rules])) + +(defn lookup-subjects + "Optimized version of lookup-subjects" + [db + {:as filters + resource :resource + permission :permission + subject-type :subject/type + _subject-relation :subject/relation ; not currently supported. + limit :limit + offset :offset}] + {:pre [(:type resource) (:id resource)]} + (let [{resource-type :type + resource-id :id} resource + + resource-eid (d/entid db resource-id)] + ; Q: can we support dynamic object type resolution? + (assert resource-eid (str "lookup-subjects (object->entid " (pr-str resource) ") must resolve to a valid Datomic entid.")) + ; todo configurable type resolution. + ;(assert (= resource-type (:eacl/type resource-ent)) (str "Resource type does not match " resource-type ".")) + (let [subject-types+eids (->> (d/q '[:find ?subject-type ?subject + :in $ % ?subject-type ?permission ?resource-type ?resource-eid + :where + (has-permission ?subject-type ?subject ?permission ?resource-type ?resource-eid) + [(not= ?subject ?resource-eid)]] + db + rules/rules-lookup-subjects + subject-type + permission + resource-type + resource-eid)) + paginated-types+eids (cond->> subject-types+eids ; better name. + offset (drop offset) + limit (take limit)) + formatted (->> paginated-types+eids + (map (fn [[type id]] + (spice-object type id))))] + ;(prn 'paginated-types+eids paginated-types+eids) + ;(prn 'formatted formatted) + ; todo: subjects cursor is WIP. We still support offset & limit. + {:data formatted + :cursor nil}))) + +(defn can? + "can? uses recursive Datalog rules. Seems to be fast enough." + [db subject permission resource] + {:pre [subject + resource + (keyword? permission) + (:id subject) + (:type subject) + + (:id resource) + (:type resource)]} + (let [; todo hoist. + {subject-type :type + subject-ident :id} subject + + {resource-type :type + resource-ident :id} resource + + ; todo assert resource-ident + + ; do we need the d/entid here? + subject-eid (d/entid db subject-ident) + resource-eid (d/entid db resource-ident)] + (if-not (and subject-eid resource-eid) ; duplicated in Spiceomic. + false + (->> (d/q '[:find ?subject . + :in $ % ?subject-type ?subject ?perm ?resource-type ?resource + :where + (has-permission ?subject-type ?subject ?perm ?resource-type ?resource)] + db + rules/check-permission-rules + subject-type + subject-eid + permission + resource-type + resource-eid) + (boolean))))) + +(defn lookup-resources + ; outdated. + "Slow version of lookup-resources that reuses check-permission-rules. + Does not support cursor, only limit & offset." + [db {:as _query + subject :subject + permission :permission + resource-type :resource/type + limit :limit + cursor :cursor}] + {:pre [(:type subject) (:id subject)]} + (let [{subject-type :type + subject-ident :id} subject + + {cursor-path :path-index + cursor-resource :resource} cursor + + {cursor-resource-type :type + cursor-resource-eid :id} cursor-resource + + subject-eid (d/entid db subject-ident)] + + (assert subject-eid (pr-str "lookup-resources requires a valid subject :id that resolves to an eid via d/entid: " subject-ident ".")) + (let [resource-types+eids (->> (d/q '[:find ?resource-type ?resource + :in $ % ?subject-type ?subject-eid ?permission ?resource-type + :where + ;(has-permission ?subject-type ?subject-eid ?permission ?resource-type ?resource) + (has-permission ?subject-type ?subject-eid ?permission ?resource-type ?resource) + [(not= ?resource ?subject-eid)]] ; do we still need this? + db + rules/check-permission-rules ; rules-lookup-resources + subject-type + subject-eid + permission + resource-type)) + sorted-by-type+eid (sort resource-types+eids) + offsetted-results (if (and cursor-resource-type cursor-resource-eid) + (->> sorted-by-type+eid + (drop-while (fn [[resource-type resource-eid]] + ; design decision on <= vs < is to skip the matching value until next cursor is smarter. + (<= resource-eid cursor-resource-eid)))) + sorted-by-type+eid) + + paginated-types+eids (cond->> offsetted-results ; resource-types+eids + ; offset (drop offset) ; cursor should take care of this. + limit (take limit)) + ;sorted-by-type+eid (sort paginated-types+eids) + formatted (->> paginated-types+eids ; sorted-by-type+eid + (map (fn [[type eid]] (spice-object type eid)))) + last-result (when (seq formatted) (last formatted))] ; Fix: only get last when there are results + {:cursor (when last-result {:resource last-result}) ; Fix: only create cursor when there's a last result + :limit limit + :data formatted}))) + +(defn count-resources + "Temporary. Just calls lookup-resources. + Super inefficient due to the sort in lookup-resources, which is not required. + Any complete count will need to materialize full index. + Note that count-resources supports cursor, so if you count from a :cursor, + it will only return the results after the cursor." + [db query] + (->> (assoc query :limit Long/MAX_VALUE) + (lookup-resources db) + (:data) + (count))) \ No newline at end of file diff --git a/modules/eacl-datomic/src/eacl/datomic/impl/indexed.clj b/modules/eacl-datomic/src/eacl/datomic/impl/indexed.clj new file mode 100644 index 000000000..f1128d2d7 --- /dev/null +++ b/modules/eacl-datomic/src/eacl/datomic/impl/indexed.clj @@ -0,0 +1,212 @@ +(ns eacl.datomic.impl.indexed + (:require [clojure.tools.logging :as log] + [datomic.api :as d] + [eacl.backend.spi :as spi] + [eacl.core :refer [spice-object]] + [eacl.engine.indexed :as engine])) + +(def ^:private forward-relationship-attr + :eacl.v7.relationship/subject-type+relation+resource-type+resource) + +(def ^:private reverse-relationship-attr + :eacl.v7.relationship/resource-type+relation+subject-type+subject) + +(defn subject->resources + [db subject-type subject-eid relation-eid resource-type cursor-resource-eid] + {:pre [subject-type subject-eid relation-eid resource-type]} + (let [attr-eid (d/entid db forward-relationship-attr) + start-tuple [subject-type + relation-eid + resource-type + (if cursor-resource-eid (inc cursor-resource-eid) 0)]] + (->> (d/seek-datoms db :eavt subject-eid attr-eid start-tuple) + (take-while + (fn [[e a v]] + (and (== subject-eid e) + (== attr-eid a) + (= [subject-type relation-eid resource-type] + (subvec (vec v) 0 3))))) + (map (fn [[_ _ v]] (nth v 3)))))) + +(defn resource->subjects + [db resource-type resource-eid relation-eid subject-type cursor-subject-eid] + {:pre [resource-type resource-eid relation-eid subject-type]} + (let [attr-eid (d/entid db reverse-relationship-attr) + start-tuple [resource-type + relation-eid + subject-type + (if cursor-subject-eid (inc cursor-subject-eid) 0)]] + (->> (d/seek-datoms db :eavt resource-eid attr-eid start-tuple) + (take-while + (fn [[e a v]] + (and (== resource-eid e) + (== attr-eid a) + (= [resource-type relation-eid subject-type] + (subvec (vec v) 0 3))))) + (map (fn [[_ _ v]] (nth v 3)))))) + +(defn relation-datoms + "Returns relation datoms for the exact resource/relation name pair." + [db resource-type relation-name] + (if (and resource-type relation-name) + (let [start-tuple [resource-type relation-name :a] + end-tuple [resource-type relation-name :z]] + (d/index-range db + :eacl.relation/resource-type+relation-name+subject-type + start-tuple + end-tuple)) + [])) + +(defn find-relation-def + "Compatibility helper retained for tests. + Returns the first matching relation definition, if any." + [db resource-type relation-name] + (when-let [datom (first (relation-datoms db resource-type relation-name))] + (d/pull db + '[:db/id + :eacl.relation/subject-type + :eacl.relation/resource-type + :eacl.relation/relation-name] + (:e datom)))) + +(defn find-permission-defs + [db resource-type permission-name] + (let [tuple-val [resource-type permission-name]] + (->> (d/datoms db :avet :eacl.permission/resource-type+permission-name tuple-val) + (map :e) + (map #(d/pull db '[*] %)) + vec))) + +(def permission-paths-cache + (atom {})) + +(defn evict-permission-paths-cache! [] + (engine/evict-permission-paths-cache! permission-paths-cache)) + +(defn direct-match-datoms-in-relationship-index + [db subject-type subject-eid relation-eid resource-type resource-eid] + (d/datoms db + :eavt + subject-eid + forward-relationship-attr + [subject-type relation-eid resource-type resource-eid])) + +(defn indexed-backend + [db] + {:cache-stamp (fn [] + (System/identityHashCode db)) + :relation-defs (fn [resource-type relation-name] + (mapv (fn [datom] + {:relation-id (:e datom) + :resource-type resource-type + :relation-name relation-name + :subject-type (nth (:v datom) 2)}) + (relation-datoms db resource-type relation-name))) + :permission-defs (fn [resource-type permission-name] + (mapv (fn [perm] + {:permission-id (:db/id perm) + :resource-type (:eacl.permission/resource-type perm) + :permission-name (:eacl.permission/permission-name perm) + :source-relation-name (:eacl.permission/source-relation-name perm) + :target-type (:eacl.permission/target-type perm) + :target-name (:eacl.permission/target-name perm)}) + (find-permission-defs db resource-type permission-name))) + :subject->resources (fn [subject-type subject-id relation-id resource-type cursor-resource-id] + (subject->resources db subject-type subject-id relation-id resource-type cursor-resource-id)) + :resource->subjects (fn [resource-type resource-id relation-id subject-type cursor-subject-id] + (resource->subjects db resource-type resource-id relation-id subject-type cursor-subject-id)) + :direct-match? (fn [subject-type subject-id relation-id resource-type resource-id] + (boolean + (seq + (direct-match-datoms-in-relationship-index db + subject-type + subject-id + relation-id + resource-type + resource-id))))}) + +(defn- backend* + [db-or-backend] + (if (and (map? db-or-backend) (contains? db-or-backend :cache-stamp)) + db-or-backend + (indexed-backend db-or-backend))) + +(defn calc-permission-paths + ([db-or-backend resource-type permission-name] + (engine/calc-permission-paths (backend* db-or-backend) resource-type permission-name)) + ([db-or-backend resource-type permission-name visited-perms] + (engine/calc-permission-paths (backend* db-or-backend) resource-type permission-name visited-perms))) + +(defn get-permission-paths + [db-or-backend resource-type permission-name] + (let [backend (backend* db-or-backend)] + (engine/get-permission-paths permission-paths-cache calc-permission-paths backend resource-type permission-name))) + +(defn traverse-permission-path + ([db subject-type subject-eid permission-name resource-type cursor-eid] + (traverse-permission-path db subject-type subject-eid permission-name resource-type cursor-eid #{})) + ([db subject-type subject-eid permission-name resource-type cursor-eid visited-paths] + (engine/traverse-permission-path + (indexed-backend db) + get-permission-paths + subject-type + subject-eid + permission-name + resource-type + cursor-eid + visited-paths))) + +(defn- internal-id + [db value] + (when value + (d/entid db value))) + +(defn can? + [db subject permission resource] + (let [subject-id (internal-id db (:id subject)) + resource-id (internal-id db (:id resource))] + (engine/can? + (indexed-backend db) + get-permission-paths + (assoc subject :id subject-id) + permission + (assoc resource :id resource-id)))) + +(defn- internalize-anchor + [db object] + (update object :id #(internal-id db %))) + +(defn lookup-resources + [db query] + (engine/lookup + (indexed-backend db) + engine/forward-direction + get-permission-paths + (update query :subject #(internalize-anchor db %)))) + +(defn lookup-subjects + [db query] + {:pre [(:type (:resource query)) (:id (:resource query))]} + (engine/lookup + (indexed-backend db) + engine/reverse-direction + get-permission-paths + (update query :resource #(internalize-anchor db %)))) + +(defn count-resources + [db query] + (engine/count-results + (indexed-backend db) + engine/forward-direction + get-permission-paths + (update query :subject #(internalize-anchor db %)) + :resource)) + +(defn count-subjects + [db query] + (engine/count-results + (indexed-backend db) + engine/reverse-direction + get-permission-paths + (update query :resource #(internalize-anchor db %)) + :subject)) diff --git a/modules/eacl-datomic/src/eacl/datomic/rules.clj b/modules/eacl-datomic/src/eacl/datomic/rules.clj new file mode 100644 index 000000000..93cdd5738 --- /dev/null +++ b/modules/eacl-datomic/src/eacl/datomic/rules.clj @@ -0,0 +1,551 @@ +(ns eacl.datomic.rules) + +;(def check-permission-rules +; "Can only be used for can? where type + id of both subject & resource object are provided." +; '[;; Reachability rules to traverse relationships: +; [(reachable ?resource ?subject) +; [(tuple ?resource ?subject) ?resource+subject] +; [?relationship :eacl.relationship/resource+subject ?resource+subject] +; +; [?relationship :eacl.relationship/resource ?resource] +; [?relationship :eacl.relationship/subject ?subject]] +; [(reachable ?resource ?subject) +; [?relationship :eacl.relationship/resource ?resource] +; [?relationship :eacl.relationship/subject ?mid] +; (reachable ?mid ?subject)] ; note inversion to traverse. +; +; ;; Direct permission check (copied and adapted from core2) +; [(has-permission ?subject ?permission-name ?resource) +; +; [(tuple ?resource ?relation-name-in-tuple ?subject) ?resource+rel-name+subject] +; [?relationship :eacl.relationship/resource+relation-name+subject ?resource+rel-name+subject] +; +; [?relationship :eacl.relationship/resource ?resource] ; subject has some relationship TO the resource +; [?relationship :eacl.relationship/relation-name ?relation-name-in-tuple] +; [?relationship :eacl.relationship/subject ?subject] ; subject of the relationship tuple +; +; ;; Permission definition: ?relation-name-in-perm-def grants ?permission-name on ?resource-type +; [(tuple ?resource-type ?relation-name-in-perm-def ?permission-name) ?res-type+relation+permission] +; [?perm-def :eacl.permission/resource-type+relation-name+permission-name ?res-type+relation+permission] +; +; [?perm-def :eacl.permission/resource-type ?resource-type] +; [?perm-def :eacl.permission/permission-name ?permission-name] +; [?perm-def :eacl.permission/relation-name ?relation-name-in-perm-def] ; THIS IS THE DIRECT GRANT +; +; ;; Match the relation name from the relationship tuple with the one in permission definition +; [(= ?relation-name-in-tuple ?relation-name-in-perm-def)] +; [(not= ?subject ?resource)]] +; +; ;; Indirect permission inheritance (copied from core2 - may need review/replacement with arrows) +; ;; This rule means: ?subject gets ?permission-name on ?resource if: +; ;; 1. A permission definition exists: for ?resource-type, ?relation-name-in-perm-def grants ?permission-name. +; ;; 2. ?resource has a relationship (as a subject of the tuple) via ?relation-name-in-perm-def to some ?target. +; ;; (e.g. doc D is "subject" of relation "group" to group G: D --group--> G) +; ;; 3. ?subject can "reach" that ?target (e.g. user U is member of group G). +; +; [(has-permission ?subject ?permission-name ?resource) +; ;; Permission definition +; [(tuple ?resource-type ?relation-name-in-perm-def ?permission-name) ?res-type+relation+permission] +; [?perm-def :eacl.permission/resource-type+relation-name+permission-name ?res-type+relation+permission] +; +; ; can these move down for speed? +; [?perm-def :eacl.permission/resource-type ?resource-type] +; [?perm-def :eacl.permission/permission-name ?permission-name] +; [?perm-def :eacl.permission/relation-name ?relation-name-in-perm-def] ; Direct relation specified in perm +; +; ;; Structural relationship: ?resource is linked to ?target via ?relation-name-in-perm-def +; [(tuple ?target ?relation-name-in-perm-def ?resource) ?target+relation+resource] +; [?structural-rel :eacl.relationship/resource+relation-name+subject ?target+relation+resource] +; +; [?structural-rel :eacl.relationship/subject ?resource] +; [?structural-rel :eacl.relationship/relation-name ?relation-name-in-perm-def] +; [?structural-rel :eacl.relationship/resource ?target] +; +; (reachable ?target ?subject) ; User must be able to reach the target of the structural relationship +; [(not= ?subject ?resource)]] +; +; ;; Arrow permission rule: ?subject gets ?perm-name-on-this-resource if it has ?perm-name-on-related on an intermediate resource +; ;; Example: User U gets :admin on VPC_X if VPC_X --:account--> ACC_Y and User U has :admin on ACC_Y. +; ;; MODIFIED based on user feedback: Rule now expects intermediate --via-relation-name--> this-resource +; ;; Example: User U gets :view on SERVER_X if ACC_Y --:account--> SERVER_X and User U has :admin on ACC_Y. +; [(has-permission ?subject ?perm-name-on-this-resource ?this-resource) +; ;; 1. Find an arrow permission definition for this-resource-type and perm-name-on-this-resource +; [(tuple ?this-resource-type +; ?via-relation-name +; ?perm-on-related +; ?perm-name-on-this-resource) ?res-type+relation+related-perm+permission] +; [?arrow-perm-def +; :eacl.arrow-permission/resource-type+source-relation-name+target-permission-name+permission-name +; ?res-type+relation+related-perm+permission] +; +; [?arrow-perm-def :eacl.arrow-permission/resource-type ?this-resource-type] +; [?arrow-perm-def :eacl.arrow-permission/permission-name ?perm-name-on-this-resource] +; [?arrow-perm-def :eacl.arrow-permission/source-relation-name ?via-relation-name] ; e.g., :account (the relation name specified in Permission) +; [?arrow-perm-def :eacl.arrow-permission/target-permission-name ?perm-on-related] ; e.g., :admin (on the intermediate/account) +; +; ;; 2. Find intermediate resource: ?intermediate-resource --via-relation-name--> ?this-resource +; [(tuple ?this-resource ?via-relation-name ?intermediate-resource) ?resource+relation+mid-resource] +; [?rel-linking-resources :eacl.relationship/resource+relation-name+subject ?resource+relation+mid-resource] +; [?rel-linking-resources :eacl.relationship/subject ?intermediate-resource] ; e.g., account is subject of tuple +; [?rel-linking-resources :eacl.relationship/relation-name ?via-relation-name] ; relation is :account +; [?rel-linking-resources :eacl.relationship/resource ?this-resource] ; e.g., server/vpc is resource of tuple +; +; ;; 3. Subject must have the target permission on the intermediate resource (recursive call) +; (has-permission ?subject ?perm-on-related ?intermediate-resource) +; [(not= ?subject ?this-resource)] ; Exclude self-references for safety +; ;; Ensure the intermediate resource is not the same as the subject to prevent some loops, +; ;; though main cycle prevention relies on data structure or more complex rule logic if needed. +; [(not= ?subject ?intermediate-resource)] +; ;; Ensure this-resource is not the same as intermediate for simple arrows like A -> B +; [(not= ?this-resource ?intermediate-resource)]]]) + +;(defn build-slow-rules [resource-type-attr] +; [;; Reachability rules to traverse relationships: +; '[(reachable ?resource ?subject) +; [(tuple ?resource ?subject) ?resource+subject] +; [?relationship :eacl.relationship/resource+subject ?resource+subject]] +; +; ;[?relationship :eacl.relationship/resource ?resource] +; ;[?relationship :eacl.relationship/subject ?subject]] +; '[(reachable ?resource ?subject) +; +; [(tuple ?resource ?mid) ?resource+mid] +; [?relationship :eacl.relationship/resource+subject ?resource+mid] ; range query? +; +; ; todo can we use tuple here? +; [?relationship :eacl.relationship/resource ?resource] +; [?relationship :eacl.relationship/subject ?mid] +; (reachable ?mid ?subject)] +; +; ;; Direct permission check (copied and adapted from core2) +; '[(has-permission ?subject ?permission-name ?resource) +; +; [(tuple ?resource ?relation-name-in-tuple ?subject) ?resource+rel-name+subject] +; [?relationship :eacl.relationship/resource+relation-name+subject ?resource+rel-name+subject] +; +; [?relationship :eacl.relationship/resource ?resource] ; subject has some relationship TO the resource +; [?relationship :eacl.relationship/relation-name ?relation-name-in-tuple] +; [?relationship :eacl.relationship/subject ?subject] ; subject of the relationship tuple +; +; ;; Permission definition: ?relation-name-in-perm-def grants ?permission-name on ?resource-type +; [(tuple ?resource-type ?relation-name-in-perm-def ?permission-name) ?res-type+relation+permission] +; [?perm-def :eacl.permission/resource-type+relation-name+permission-name ?res-type+relation+permission] +; +; [?perm-def :eacl.permission/resource-type ?resource-type] +; [?perm-def :eacl.permission/permission-name ?permission-name] +; [?perm-def :eacl.permission/relation-name ?relation-name-in-perm-def] ; THIS IS THE DIRECT GRANT +; +; ;; Match the relation name from the relationship tuple with the one in permission definition +; [(= ?relation-name-in-tuple ?relation-name-in-perm-def)] +; [(not= ?subject ?resource)] ; can we avoid this? +; [?resource :eacl/type ?resource-type]] ; this is super slow. different rules WIP. +; +; ;; Indirect permission inheritance (copied from core2 - may need review/replacement with arrows) +; ;; This rule means: ?subject gets ?permission-name on ?resource if: +; ;; 1. A permission definition exists: for ?resource-type, ?relation-name-in-perm-def grants ?permission-name. +; ;; 2. ?resource has a relationship (as a subject of the tuple) via ?relation-name-in-perm-def to some ?target. +; ;; (e.g. doc D is "subject" of relation "group" to group G: D --group--> G) +; ;; 3. ?subject can "reach" that ?target (e.g. user U is member of group G). +; (into +; ['(has-permission ?subject ?permission-name ?resource)] +; +; '[;; Permission definition +; [(tuple ?resource-type ?relation-name-in-perm-def ?permission-name) ?res-type+relation+permission] +; [?perm-def :eacl.permission/resource-type+relation-name+permission-name ?res-type+relation+permission] +; +; [?perm-def :eacl.permission/resource-type ?resource-type] +; [?perm-def :eacl.permission/permission-name ?permission-name] +; [?perm-def :eacl.permission/relation-name ?relation-name-in-perm-def] ; Direct relation specified in perm +; +; ;; Structural relationship: ?resource is linked to ?target via ?relation-name-in-perm-def +; [(tuple ?target ?relation-name-in-perm-def ?resource) ?target+relation+resource] +; [?structural-rel :eacl.relationship/resource+relation-name+subject ?target+relation+resource] +; +; [?structural-rel :eacl.relationship/subject ?resource] +; [?structural-rel :eacl.relationship/relation-name ?relation-name-in-perm-def] +; [?structural-rel :eacl.relationship/resource ?target] +; +; (reachable ?target ?subject) ; User must be able to reach the target of the structural relationship +; [(not= ?subject ?resource)] +; [?resource :eacl/type ?resource-type]]) +; +; ;; Arrow permission rule: ?subject gets ?perm-name-on-this-resource if it has ?perm-name-on-related on an intermediate resource +; ;; Example: User U gets :admin on VPC_X if VPC_X --:account--> ACC_Y and User U has :admin on ACC_Y. +; ;; MODIFIED based on user feedback: Rule now expects intermediate --via-relation-name--> this-resource +; ;; Example: User U gets :view on SERVER_X if ACC_Y --:account--> SERVER_X and User U has :admin on ACC_Y. +; '[(has-permission ?subject ?perm-name-on-this-resource ?this-resource) +; +; ;; 1. Find an arrow permission definition for this-resource-type and perm-name-on-this-resource +; [(tuple ?this-resource-type +; ?via-relation-name +; ?perm-on-related +; ?perm-name-on-this-resource) ?res-type+relation+related-perm+permission] +; [?arrow-perm-def +; :eacl.arrow-permission/resource-type+source-relation-name+target-permission-name+permission-name +; ?res-type+relation+related-perm+permission] +; +; ; can these move down for speed, or be decoupled in a 2nd phase? +; [?arrow-perm-def :eacl.arrow-permission/resource-type ?this-resource-type] +; [?arrow-perm-def :eacl.arrow-permission/permission-name ?perm-name-on-this-resource] +; [?arrow-perm-def :eacl.arrow-permission/source-relation-name ?via-relation-name] ; e.g., :account (the relation name specified in Permission) +; [?arrow-perm-def :eacl.arrow-permission/target-permission-name ?perm-on-related] ; e.g., :admin (on the intermediate/account) +; +; ;; 2. Find intermediate resource: ?intermediate-resource --via-relation-name--> ?this-resource +; [(tuple ?this-resource ?via-relation-name ?intermediate-resource) ?resource+relation+mid-resource] +; [?rel-linking-resources :eacl.relationship/resource+relation-name+subject ?resource+relation+mid-resource] +; +; [?rel-linking-resources :eacl.relationship/subject ?intermediate-resource] ; e.g., account is subject of tuple +; [?rel-linking-resources :eacl.relationship/relation-name ?via-relation-name] ; relation is :account +; [?rel-linking-resources :eacl.relationship/resource ?this-resource] ; e.g., server/vpc is resource of tuple +; +; ;; 3. Subject must have the target permission on the intermediate resource (recursive call) +; (has-permission ?subject ?perm-on-related ?intermediate-resource) +; [(not= ?subject ?this-resource)] ; Exclude self-references for safety +; ;; Ensure the intermediate resource is not the same as the subject to prevent some loops, +; ;; though main cycle prevention relies on data structure or more complex rule logic if needed. +; [(not= ?subject ?intermediate-resource)] +; ;; Ensure this-resource is not the same as intermediate for simple arrows like A -> B +; [(not= ?this-resource ?intermediate-resource)] +; [?this-resource :eacl/type ?this-resource-type]]]) ; this is super slow. different rules WIP.]]) + +(def slow-lookup-rules (build-slow-rules :eacl/type)) + +(def rules-lookup-subjects + '[;; Reachability rules to traverse relationships: + [(reachable ?resource ?subject) ; I think we need types here for speed. + [(tuple ?resource ?subject) ?resource+subject] + [?relationship :eacl.relationship/resource+subject ?resource+subject] + + [?relationship :eacl.relationship/resource ?resource] + [?relationship :eacl.relationship/subject ?subject]] + + [(reachable ?resource ?subject) + + [(tuple ?resource ?mid) ?resource+mid] + [?relationship :eacl.relationship/resource+subject ?resource+mid] ; range query? + + ; todo can we use tuple here? + [?relationship :eacl.relationship/resource ?resource] + [?relationship :eacl.relationship/subject ?mid] + (reachable ?mid ?subject)] + + ;; Direct permission check (copied and adapted from core2) + [(has-permission ?subject-type ?subject ?permission-name ?resource) + + [(tuple ?resource ?relation-name-in-tuple ?subject) ?resource+rel-name+subject] + [?relationship :eacl.relationship/resource+relation-name+subject ?resource+rel-name+subject] + + [?relationship :eacl.relationship/resource ?resource] ; subject has some relationship TO the resource + [?relationship :eacl.relationship/relation-name ?relation-name-in-tuple] + [?relationship :eacl.relationship/subject ?subject] ; subject of the relationship tuple + + ;; Permission definition: ?relation-name-in-perm-def grants ?permission-name on ?resource-type + [(tuple ?resource-type ?relation-name-in-perm-def ?permission-name) ?res-type+relation+permission] + [?perm-def :eacl.permission/resource-type+relation-name+permission-name ?res-type+relation+permission] + + [?perm-def :eacl.permission/resource-type ?resource-type] + [?perm-def :eacl.permission/permission-name ?permission-name] + [?perm-def :eacl.permission/relation-name ?relation-name-in-perm-def] ; THIS IS THE DIRECT GRANT + + ;; Match the relation name from the relationship tuple with the one in permission definition + [(= ?relation-name-in-tuple ?relation-name-in-perm-def)] + [(not= ?subject ?resource)] ; can we avoid this? + [?subject :eacl/type ?subject-type]] ; this is super slow. different rules WIP. + + ;; Indirect permission inheritance (copied from core2 - may need review/replacement with arrows) + ;; This rule means: ?subject gets ?permission-name on ?resource if: + ;; 1. A permission definition exists: for ?resource-type, ?relation-name-in-perm-def grants ?permission-name. + ;; 2. ?resource has a relationship (as a subject of the tuple) via ?relation-name-in-perm-def to some ?target. + ;; (e.g. doc D is "subject" of relation "group" to group G: D --group--> G) + ;; 3. ?subject can "reach" that ?target (e.g. user U is member of group G). + + [(has-permission ?subject-type ?subject ?permission-name ?resource) + ;; Permission definition + [(tuple ?resource-type ?relation-name-in-perm-def ?permission-name) ?res-type+relation+permission] + [?perm-def :eacl.permission/resource-type+relation-name+permission-name ?res-type+relation+permission] + + [?perm-def :eacl.permission/resource-type ?resource-type] + [?perm-def :eacl.permission/permission-name ?permission-name] + [?perm-def :eacl.permission/relation-name ?relation-name-in-perm-def] ; Direct relation specified in perm + + ;; Structural relationship: ?resource is linked to ?target via ?relation-name-in-perm-def + [(tuple ?target ?relation-name-in-perm-def ?resource) ?target+relation+resource] + [?structural-rel :eacl.relationship/resource+relation-name+subject ?target+relation+resource] + + [?structural-rel :eacl.relationship/subject ?resource] + [?structural-rel :eacl.relationship/relation-name ?relation-name-in-perm-def] + [?structural-rel :eacl.relationship/resource ?target] + + (reachable ?target ?subject) ; User must be able to reach the target of the structural relationship + [(not= ?subject ?resource)] + [?subject :eacl/type ?subject-type]] + + ;; Arrow permission rule: ?subject gets ?perm-name-on-this-resource if it has ?perm-name-on-related on an intermediate resource + ;; Example: User U gets :admin on VPC_X if VPC_X --:account--> ACC_Y and User U has :admin on ACC_Y. + ;; MODIFIED based on user feedback: Rule now expects intermediate --via-relation-name--> this-resource + ;; Example: User U gets :view on SERVER_X if ACC_Y --:account--> SERVER_X and User U has :admin on ACC_Y. + [(has-permission ?subject-type ?subject ?perm-name-on-this-resource ?this-resource) + + ; this order looks wrong. + ;; 1. Find an arrow permission definition for this-resource-type and perm-name-on-this-resource + [(tuple ?this-resource-type + ?via-relation-name + ?perm-on-related + ?perm-name-on-this-resource) ?res-type+relation+related-perm+permission] + [?arrow-perm-def + :eacl.arrow-permission/resource-type+source-relation-name+target-permission-name+permission-name + ?res-type+relation+related-perm+permission] + + ; can these move down for speed, or be decoupled in a 2nd phase? + [?arrow-perm-def :eacl.arrow-permission/resource-type ?this-resource-type] + [?arrow-perm-def :eacl.arrow-permission/permission-name ?perm-name-on-this-resource] + [?arrow-perm-def :eacl.arrow-permission/source-relation-name ?via-relation-name] ; e.g., :account (the relation name specified in Permission) + [?arrow-perm-def :eacl.arrow-permission/target-permission-name ?perm-on-related] ; e.g., :admin (on the intermediate/account) + + ;; 2. Find intermediate resource: ?intermediate-resource --via-relation-name--> ?this-resource + [(tuple ?this-resource ?via-relation-name ?intermediate-resource) ?resource+relation+mid-resource] + [?rel-linking-resources :eacl.relationship/resource+relation-name+subject ?resource+relation+mid-resource] + + [?rel-linking-resources :eacl.relationship/subject ?intermediate-resource] ; e.g., account is subject of tuple + [?rel-linking-resources :eacl.relationship/relation-name ?via-relation-name] ; relation is :account + [?rel-linking-resources :eacl.relationship/resource ?this-resource] ; e.g., server/vpc is resource of tuple + + ;; 3. Subject must have the target permission on the intermediate resource (recursive call) + (has-permission ?subject-type ?subject ?perm-on-related ?intermediate-resource) + [(not= ?subject ?this-resource)] ; Exclude self-references for safety + ;; Ensure the intermediate resource is not the same as the subject to prevent some loops, + ;; though main cycle prevention relies on data structure or more complex rule logic if needed. + [(not= ?subject ?intermediate-resource)] + ;; Ensure this-resource is not the same as intermediate for simple arrows like A -> B + [(not= ?this-resource ?intermediate-resource)] + ; TODO: this-resource looks dubious here. do we need it? + [?this-resource :eacl/type ?this-resource-type]]]) + +(def rules-lookup-resources + ; resource look has known subject Type + ID, and known resource type. + '[;; Reachability rules to traverse relationships: + [(reachable ?resource ?subject) ; I think we need types here for speed. + [(tuple ?resource ?subject) ?resource+subject] + [?relationship :eacl.relationship/resource+subject ?resource+subject] + + [?relationship :eacl.relationship/resource ?resource] + [?relationship :eacl.relationship/subject ?subject]] + + [(reachable ?resource ?subject) + + [(tuple ?resource ?mid) ?resource+mid] + [?relationship :eacl.relationship/resource+subject ?resource+mid] ; range query? + + ; todo can we use tuple here? + [?relationship :eacl.relationship/resource ?resource] + [?relationship :eacl.relationship/subject ?mid] + (reachable ?mid ?subject)] + + ;; Direct permission check (copied and adapted from core2) + [(has-permission ?subject ?permission-name ?resource-type ?resource) + + [(tuple ?resource ?relation-name-in-tuple ?subject) ?resource+rel-name+subject] + [?relationship :eacl.relationship/resource+relation-name+subject ?resource+rel-name+subject] + + [?relationship :eacl.relationship/resource ?resource] ; subject has some relationship TO the resource + [?relationship :eacl.relationship/relation-name ?relation-name-in-tuple] + [?relationship :eacl.relationship/subject ?subject] ; subject of the relationship tuple + + ;; Permission definition: ?relation-name-in-perm-def grants ?permission-name on ?resource-type + [(tuple ?resource-type ?relation-name-in-perm-def ?permission-name) ?res-type+relation+permission] + [?perm-def :eacl.permission/resource-type+relation-name+permission-name ?res-type+relation+permission] + + [?perm-def :eacl.permission/resource-type ?resource-type] + [?perm-def :eacl.permission/permission-name ?permission-name] + [?perm-def :eacl.permission/relation-name ?relation-name-in-perm-def] ; THIS IS THE DIRECT GRANT + + ;; Match the relation name from the relationship tuple with the one in permission definition + [(= ?relation-name-in-tuple ?relation-name-in-perm-def)] + [(not= ?subject ?resource)] ; can we avoid this? + [?resource :eacl/type ?resource-type]] + + ;; Indirect permission inheritance (copied from core2 - may need review/replacement with arrows) + ;; This rule means: ?subject gets ?permission-name on ?resource if: + ;; 1. A permission definition exists: for ?resource-type, ?relation-name-in-perm-def grants ?permission-name. + ;; 2. ?resource has a relationship (as a subject of the tuple) via ?relation-name-in-perm-def to some ?target. + ;; (e.g. doc D is "subject" of relation "group" to group G: D --group--> G) + ;; 3. ?subject can "reach" that ?target (e.g. user U is member of group G). + + [(has-permission ?subject ?permission-name ?resource-type ?resource) + ;; Permission definition + ;; order looks dubious + [(tuple ?resource-type ?relation-name-in-perm-def ?permission-name) ?res-type+relation+permission] + [?perm-def :eacl.permission/resource-type+relation-name+permission-name ?res-type+relation+permission] + + [?perm-def :eacl.permission/resource-type ?resource-type] + [?perm-def :eacl.permission/permission-name ?permission-name] + [?perm-def :eacl.permission/relation-name ?relation-name-in-perm-def] ; Direct relation specified in perm + + ;; Structural relationship: ?resource is linked to ?target via ?relation-name-in-perm-def + [(tuple ?target ?relation-name-in-perm-def ?resource) ?target+relation+resource] + [?structural-rel :eacl.relationship/resource+relation-name+subject ?target+relation+resource] + + [?structural-rel :eacl.relationship/subject ?resource] + [?structural-rel :eacl.relationship/relation-name ?relation-name-in-perm-def] + [?structural-rel :eacl.relationship/resource ?target] + + (reachable ?target ?subject) ; User must be able to reach the target of the structural relationship + [(not= ?subject ?resource)] + [?resource :eacl/type ?this-resource-type]] ; is this correct? + + ;; Arrow permission rule: ?subject gets ?perm-name-on-this-resource if it has ?perm-name-on-related on an intermediate resource + ;; Example: User U gets :admin on VPC_X if VPC_X --:account--> ACC_Y and User U has :admin on ACC_Y. + ;; MODIFIED based on user feedback: Rule now expects intermediate --via-relation-name--> this-resource + ;; Example: User U gets :view on SERVER_X if ACC_Y --:account--> SERVER_X and User U has :admin on ACC_Y. + [(has-permission ?subject ?perm-name-on-this-resource ?this-resource-type ?this-resource) + + ;; 1. Find an arrow permission definition for this-resource-type and perm-name-on-this-resource + [(tuple ?this-resource-type + ?via-relation-name + ?perm-on-related + ?perm-name-on-this-resource) ?res-type+relation+related-perm+permission] + [?arrow-perm-def + :eacl.arrow-permission/resource-type+source-relation-name+target-permission-name+permission-name + ?res-type+relation+related-perm+permission] + + ; can these move down for speed, or be decoupled in a 2nd phase? + [?arrow-perm-def :eacl.arrow-permission/resource-type ?this-resource-type] + [?arrow-perm-def :eacl.arrow-permission/permission-name ?perm-name-on-this-resource] + [?arrow-perm-def :eacl.arrow-permission/source-relation-name ?via-relation-name] ; e.g., :account (the relation name specified in Permission) + [?arrow-perm-def :eacl.arrow-permission/target-permission-name ?perm-on-related] ; e.g., :admin (on the intermediate/account) + + ;; 2. Find intermediate resource: ?intermediate-resource --via-relation-name--> ?this-resource + [(tuple ?this-resource ?via-relation-name ?intermediate-resource) ?resource+relation+mid-resource] + [?rel-linking-resources :eacl.relationship/resource+relation-name+subject ?resource+relation+mid-resource] + + [?rel-linking-resources :eacl.relationship/subject ?intermediate-resource] ; e.g., account is subject of tuple + [?rel-linking-resources :eacl.relationship/relation-name ?via-relation-name] ; relation is :account + [?rel-linking-resources :eacl.relationship/resource ?this-resource] ; e.g., server/vpc is resource of tuple + + [?intermediate-resource :eacl/type ?intermediate-resource-type] ; do we need this? + + ;; 3. Subject must have the target permission on the intermediate resource (recursive call) + (has-permission ?subject ?perm-on-related ?intermediate-resource-type ?intermediate-resource) + [(not= ?subject ?this-resource)] ; Exclude self-references for safety + ;; Ensure the intermediate resource is not the same as the subject to prevent some loops, + ;; though main cycle prevention relies on data structure or more complex rule logic if needed. + [(not= ?subject ?intermediate-resource)] + ;; Ensure this-resource is not the same as intermediate for simple arrows like A -> B + [(not= ?this-resource ?intermediate-resource)] + [?this-resource :eacl/type ?this-resource-type]]]) + +;(def rules-lookup-subjects +; ; lookup-subjects knows resource & subject type which implies knowing resource type. +; '[;; Reachability rules to traverse relationships: +; [(reachable ?resource ?subject) +; ; todo use reachable tuple +; [(tuple ?resource ?subject) ?resource+subject] +; [?relationship :eacl.relationship/resource+subject ?resource+subject] +; +; [?relationship :eacl.relationship/resource ?resource] +; [?relationship :eacl.relationship/subject ?subject]] +; +; [(reachable ?resource ?subject) +; ; don't think this will work... +; [(tuple ?resource ?mid) ?resource+mid] +; [?relationship :eacl.relationship/resource+subject ?resource+mid] +; +; [?relationship :eacl.relationship/resource ?resource] +; [?relationship :eacl.relationship/subject ?mid] +; (reachable ?mid ?subject)] +; +; ;; Direct permission check +; [(has-permission ?resource ?permission-name ?subject-type ?subject) +; +; [(tuple ?resource ?relation-name-in-tuple ?subject) ?resource+rel-name+subject] +; [?relationship :eacl.relationship/resource+relation-name+subject ?resource+rel-name+subject] +; +; [?relationship :eacl.relationship/resource ?resource] ; subject has some relationship TO the resource +; [?relationship :eacl.relationship/relation-name ?relation-name-in-tuple] +; [?relationship :eacl.relationship/subject ?subject] ; subject of the relationship tuple +; +; ;; Permission definition: ?relation-name-in-perm-def grants ?permission-name on ?resource-type +; [(tuple ?resource-type ?relation-name-in-tuple ?permission-name) ?res-type+relation+permission] +; [?perm-def :eacl.permission/resource-type+relation-name+permission-name ?res-type+relation+permission] +; +; [?perm-def :eacl.permission/resource-type ?resource-type] +; [?perm-def :eacl.permission/permission-name ?permission-name] +; [?perm-def :eacl.permission/relation-name ?relation-name-in-tuple] ; THIS IS THE DIRECT GRANT +; +; ;; Match the relation name from the relationship tuple with the one in permission definition +; ;[(= ?relation-name-in-tuple ?relation-name-in-perm-def)] ; can this be unified better? should this be higher up? +; +; [(not= ?subject ?resource)]] +; +; ;; Indirect permission inheritance (copied from core2 - may need review/replacement with arrows) +; ;; This rule means: ?subject gets ?permission-name on ?resource if: +; ;; 1. A permission definition exists: for ?resource-type, ?relation-name-in-perm-def grants ?permission-name. +; ;; 2. ?resource has a relationship (as a subject of the tuple) via ?relation-name-in-perm-def to some ?target. +; ;; (e.g. doc D is "subject" of relation "group" to group G: D --group--> G) +; ;; 3. ?subject can "reach" that ?target (e.g. user U is member of group G). +; +; [(has-permission ?resource ?permission-name ?subject-type ?subject) +; ;; Permission definition +; ;; I don't think tuple makes sense here... +; ;[(tuple ?resource-type ?relation-name-in-perm-def ?permission-name) ?res-type+relation+permission] +; ;[?perm-def :eacl.permission/resource-type+relation-name+permission-name ?res-type+relation+permission] +; +; [?perm-def :eacl.permission/resource-type ?resource-type] +; [?perm-def :eacl.permission/permission-name ?permission-name] +; [?perm-def :eacl.permission/relation-name ?relation-name-in-perm-def] ; Direct relation specified in perm +; +; ;; Structural relationship: ?resource is linked to ?target via ?relation-name-in-perm-def +; [(tuple ?target ?relation-name-in-perm-def ?resource) ?target+relation+resource] +; [?structural-rel :eacl.relationship/resource+relation-name+subject ?target+relation+resource] +; +; [?structural-rel :eacl.relationship/subject ?resource] +; [?structural-rel :eacl.relationship/relation-name ?relation-name-in-perm-def] +; [?structural-rel :eacl.relationship/resource ?target] +; +; (reachable ?target ?subject) ; User must be able to reach the target of the structural relationship +; [?resource :eacl/type ?resource-type] ; super slow. different rules WIP. +; [?subject :eacl/type ?subject-type] +; [(not= ?subject ?resource)]] +; +; ;; Arrow permission rule: ?subject gets ?perm-name-on-this-resource if it has ?perm-name-on-related on an intermediate resource +; ;; Example: User U gets :admin on VPC_X if VPC_X --:account--> ACC_Y and User U has :admin on ACC_Y. +; ;; MODIFIED based on user feedback: Rule now expects intermediate --via-relation-name--> this-resource +; ;; Example: User U gets :view on SERVER_X if ACC_Y --:account--> SERVER_X and User U has :admin on ACC_Y. +; [(has-permission ?this-resource ?perm-name-on-this-resource ?subject-type ?subject) +; +; ;; 1. Find an arrow permission definition for this-resource-type and perm-name-on-this-resource +; [(tuple ?this-resource-type +; ?via-relation-name +; ?perm-on-related +; ?perm-name-on-this-resource) ?res-type+relation+related-perm+permission] +; [?arrow-perm-def +; :eacl.arrow-permission/resource-type+source-relation-name+target-permission-name+permission-name +; ?res-type+relation+related-perm+permission] +; +; ; can these move down for speed, or be decoupled in a 2nd phase? +; [?arrow-perm-def :eacl.arrow-permission/resource-type ?this-resource-type] +; [?arrow-perm-def :eacl.arrow-permission/permission-name ?perm-name-on-this-resource] +; [?arrow-perm-def :eacl.arrow-permission/source-relation-name ?via-relation-name] ; e.g., :account (the relation name specified in Permission) +; [?arrow-perm-def :eacl.arrow-permission/target-permission-name ?perm-on-related] ; e.g., :admin (on the intermediate/account) +; +; ;; 2. Find intermediate resource: ?intermediate-resource --via-relation-name--> ?this-resource +; [(tuple ?this-resource ?via-relation-name ?intermediate-resource) ?resource+relation+mid-resource] +; [?rel-linking-resources :eacl.relationship/resource+relation-name+subject ?resource+relation+mid-resource] +; +; [?rel-linking-resources :eacl.relationship/subject ?intermediate-resource] ; e.g., account is subject of tuple +; [?rel-linking-resources :eacl.relationship/relation-name ?via-relation-name] ; relation is :account +; [?rel-linking-resources :eacl.relationship/resource ?this-resource] ; e.g., server/vpc is resource of tuple +; +; ;[?this-resource :eacl/type ?this-resource-type] +; ;[?subject :eacl/type ?subject-type] +; [?intermediate-resource :resource/type ?intermediate-resource-type] +; +; ;; 3. Subject must have the target permission on the intermediate resource (recursive call) +; (has-permission ?subject ?perm-on-related ?intermediate-resource-type ?intermediate-resource) +; [(not= ?subject ?this-resource)] ; Exclude self-references for safety +; ;; Ensure the intermediate resource is not the same as the subject to prevent some loops, +; ;; though main cycle prevention relies on data structure or more complex rule logic if needed. +; [(not= ?subject ?intermediate-resource)] +; ;; Ensure this-resource is not the same as intermediate for simple arrows like A -> B +; [(not= ?this-resource ?intermediate-resource)]]]) +; this is super slow. different rules WIP.]]) diff --git a/modules/eacl-datomic/src/eacl/datomic/rules/optimized.clj b/modules/eacl-datomic/src/eacl/datomic/rules/optimized.clj new file mode 100644 index 000000000..3cd59d688 --- /dev/null +++ b/modules/eacl-datomic/src/eacl/datomic/rules/optimized.clj @@ -0,0 +1,427 @@ +(ns eacl.datomic.rules.optimized + "Optimized Datalog rules for EACL performance improvements") + +(def check-permission-rules + "Recursive Datalog rules for can? & lookup-resources using unified permission schema." + '[;; Optimized reachability using tuples + [(reachable ?resource ?subject) + ;; Direct relationship - most common case + [(tuple ?resource ?subject) ?resource+subject] + [?relationship :eacl.relationship/resource+subject ?resource+subject]] + + [(reachable ?resource ?subject) + ;; Indirect relationship - use tuple for first hop + [(tuple ?resource ?mid) ?resource+mid] + [?relationship :eacl.relationship/resource+subject ?resource+mid] + ;; Only traverse if needed + (reachable ?mid ?subject)] + + ;; Direct permission - unified schema (no source-relation-name) + [(has-permission ?subject-type ?subject ?permission-name ?resource-type ?resource) + + ;; Find relationships for this resource + [?relationship :eacl.relationship/resource ?resource] + [?relationship :eacl.relationship/resource-type ?resource-type] + [?relationship :eacl.relationship/subject ?subject] + [?relationship :eacl.relationship/subject-type ?subject-type] + [?relationship :eacl.relationship/relation-name ?relation-name] + + ;; Find direct permission (no source-relation-name means direct) + [?perm-def :eacl.permission/resource-type ?resource-type] + [?perm-def :eacl.permission/permission-name ?permission-name] + [?perm-def :eacl.permission/target-type :relation] + [?perm-def :eacl.permission/target-name ?relation-name] + [?perm-def :eacl.permission/source-relation-name :self] + + ;; Exclude self-references + [(not= ?subject ?resource)]] + + ;; Indirect permission inheritance via direct permissions + [(has-permission ?subject-type ?subject ?permission-name ?resource-type ?resource) + + ;; Find direct permission definitions for this resource type + [?perm-def :eacl.permission/resource-type ?resource-type] + [?perm-def :eacl.permission/permission-name ?permission-name] + [?perm-def :eacl.permission/target-type :relation] + [?perm-def :eacl.permission/target-name ?relation-name] + [?perm-def :eacl.permission/source-relation-name :self] + + ;; Find structural relationships where resource is the subject + [?structural-rel :eacl.relationship/subject ?resource] + [?structural-rel :eacl.relationship/subject-type ?resource-type] + [?structural-rel :eacl.relationship/relation-name ?relation-name] + [?structural-rel :eacl.relationship/resource ?target] + [?structural-rel :eacl.relationship/resource-type ?target-type] + + ;; Check reachability last + (reachable ?target ?subject) + [(not= ?subject ?resource)]] + + ;; Arrow permission to permission - unified schema + [(has-permission ?subject-type ?subject ?perm-name-on-this-resource ?this-resource-type ?this-resource) + + ;; Find arrow permission definitions that target permissions + [?arrow-perm :eacl.permission/resource-type ?this-resource-type] + [?arrow-perm :eacl.permission/permission-name ?perm-name-on-this-resource] + [?arrow-perm :eacl.permission/source-relation-name ?via-relation] + [?arrow-perm :eacl.permission/target-type :permission] + [?arrow-perm :eacl.permission/target-name ?perm-on-related] + + ;; Find intermediate resource + [?rel-linking :eacl.relationship/resource-type ?this-resource-type] + [?rel-linking :eacl.relationship/resource ?this-resource] + [?rel-linking :eacl.relationship/relation-name ?via-relation] + [?rel-linking :eacl.relationship/subject ?intermediate-resource] + [?rel-linking :eacl.relationship/subject-type ?intermediate-resource-type] + + ;; Recursive permission check + (has-permission ?subject-type ?subject ?perm-on-related ?intermediate-resource-type ?intermediate-resource) + + ;; Safety checks + [(not= ?subject ?this-resource)] + [(not= ?subject ?intermediate-resource)] + [(not= ?this-resource ?intermediate-resource)]] + + ;; Arrow permission to relation - unified schema + [(has-permission ?subject-type ?subject ?perm-name-on-this-resource ?this-resource-type ?this-resource) + + ;; Find arrow permission definitions that target relations + [?arrow-perm :eacl.permission/resource-type ?this-resource-type] + [?arrow-perm :eacl.permission/permission-name ?perm-name-on-this-resource] + [?arrow-perm :eacl.permission/source-relation-name ?via-relation] + [?arrow-perm :eacl.permission/target-type :relation] + [?arrow-perm :eacl.permission/target-name ?target-relation] + + ;; Find intermediate resource + [?rel-linking :eacl.relationship/resource-type ?this-resource-type] + [?rel-linking :eacl.relationship/resource ?this-resource] + [?rel-linking :eacl.relationship/relation-name ?via-relation] + [?rel-linking :eacl.relationship/subject ?intermediate-resource] + [?rel-linking :eacl.relationship/subject-type ?intermediate-resource-type] + + ;; Check if subject has the target relation on intermediate resource + [?target-rel :eacl.relationship/resource ?intermediate-resource] + [?target-rel :eacl.relationship/resource-type ?intermediate-resource-type] + [?target-rel :eacl.relationship/subject ?subject] + [?target-rel :eacl.relationship/subject-type ?subject-type] + [?target-rel :eacl.relationship/relation-name ?target-relation] + + ;; Safety checks + [(not= ?subject ?this-resource)] + [(not= ?subject ?intermediate-resource)] + [(not= ?this-resource ?intermediate-resource)]]]) + +;(def check-permission-rules-broken +; '[(reachable ?resource ?subject) +; [?structural-rel :eacl.relationship/subject ?subject] +; [?structural-rel :eacl.relationship/resource ?resource] +; +; (reachable ?resource ?subject) +; [?structural-rel :eacl.relationship/subject ?mid] +; [?structural-rel :eacl.relationship/resource ?resource] +; (reachable ?mid ?subject) +; +; (has-permission ?subject-type ?subject ?permission-name ?resource-type ?resource) +; [?relationship :eacl.relationship/resource ?resource] +; [?relationship :eacl.relationship/subject ?subject] +; [?relationship :eacl.relationship/relation-name ?relation-name] +; [?relationship :eacl.relationship/resource-type ?resource-type] +; [?relationship :eacl.relationship/subject-type ?subject-type] +; [(tuple ?resource-type ?relation-name ?permission-name) ?perm-tuple] +; [?perm-def :eacl.permission/resource-type+relation-name+permission-name ?perm-tuple] +; [(not= ?subject ?resource)] +; +; (has-permission ?subject-type ?subject ?permission-name ?resource-type ?resource) +; [?perm-def :eacl.permission/resource-type ?resource-type] +; [?perm-def :eacl.permission/permission-name ?permission-name] +; [?perm-def :eacl.permission/relation-name ?relation-name] +; [?structural-rel :eacl.relationship/subject ?resource] +; [?structural-rel :eacl.relationship/relation-name ?relation-name] +; [?structural-rel :eacl.relationship/resource ?target] +; [?structural-rel :eacl.relationship/subject-type ?resource-type] +; [?structural-rel :eacl.relationship/resource-type ?target-type] +; (reachable ?target ?subject) +; [(not= ?subject ?resource)] +; +; (has-permission ?subject-type ?subject ?perm-name-on-this-resource ?this-resource-type ?this-resource) +; [?arrow-perm :eacl.arrow-permission/resource-type ?this-resource-type] +; [?arrow-perm :eacl.arrow-permission/permission-name ?perm-name-on-this-resource] +; [?arrow-perm :eacl.arrow-permission/source-relation-name ?via-relation] +; [?arrow-perm :eacl.arrow-permission/target-permission-name ?perm-on-related] +; [?rel-linking :eacl.relationship/resource ?this-resource] +; [?rel-linking :eacl.relationship/resource-type ?this-resource-type] +; [?rel-linking :eacl.relationship/relation-name ?via-relation] +; [?rel-linking :eacl.relationship/subject ?intermediate-resource] +; [?rel-linking :eacl.relationship/subject-type ?intermediate-resource-type] +; (has-permission ?subject-type ?subject ?perm-on-related ?intermediate-resource-type ?intermediate-resource) +; [(not= ?subject ?this-resource)] +; [(not= ?subject ?intermediate-resource)] +; [(not= ?this-resource ?intermediate-resource)]]) + +(def rules-lookup-subjects + "Optimized rules for lookup-subjects using unified permission schema" + '[;; Reachability rules remain the same + ; Note: resource is known. subject is unknown. + [(reachable ?resource ?subject) + [(tuple ?resource ?subject) ?resource+subject] + [?relationship :eacl.relationship/resource+subject ?resource+subject]] + + [(reachable ?resource ?subject) + [(tuple ?resource ?mid) ?resource+mid] + [?relationship :eacl.relationship/resource+subject ?resource+mid] + (reachable ?mid ?subject)] + + ;; Direct permission check - unified schema + [(has-permission ?subject-type ?subject ?permission-name ?resource-type ?resource) + + ;; Find relationships for this resource + [?relationship :eacl.relationship/resource ?resource] + [?relationship :eacl.relationship/subject ?subject] + [?relationship :eacl.relationship/relation-name ?relation-name] + [?relationship :eacl.relationship/resource-type ?resource-type] + [?relationship :eacl.relationship/subject-type ?subject-type] + + ;; Find direct permission (no source-relation-name means direct) + [?perm-def :eacl.permission/resource-type ?resource-type] + [?perm-def :eacl.permission/permission-name ?permission-name] + [?perm-def :eacl.permission/target-type :relation] + [?perm-def :eacl.permission/target-name ?relation-name] + [?perm-def :eacl.permission/source-relation-name :self] + + [(not= ?subject ?resource)]] + + ;; Indirect permission inheritance via direct permissions + [(has-permission ?subject-type ?subject ?permission-name ?resource-type ?resource) + ;; Find direct permission definitions + [?perm-def :eacl.permission/resource-type ?resource-type] + [?perm-def :eacl.permission/permission-name ?permission-name] + [?perm-def :eacl.permission/target-type :relation] + [?perm-def :eacl.permission/target-name ?relation-name] + [?perm-def :eacl.permission/source-relation-name :self] + + ;; Find structural relationships + [?structural-rel :eacl.relationship/subject ?resource] + [?structural-rel :eacl.relationship/relation-name ?relation-name] + [?structural-rel :eacl.relationship/resource ?target] + [?structural-rel :eacl.relationship/subject-type ?resource-type] + [?structural-rel :eacl.relationship/resource-type ?target-type] + + (reachable ?target ?subject) + [(not= ?subject ?resource)]] + + ;; Arrow permission to permission - unified schema + [(has-permission ?subject-type ?subject ?perm-name-on-this-resource ?this-resource-type ?this-resource) + + ;; Find arrow permissions that target permissions + [?arrow-perm :eacl.permission/resource-type ?this-resource-type] + [?arrow-perm :eacl.permission/permission-name ?perm-name-on-this-resource] + [?arrow-perm :eacl.permission/source-relation-name ?via-relation] + [?arrow-perm :eacl.permission/target-type :permission] + [?arrow-perm :eacl.permission/target-name ?perm-on-related] + + ;; Find intermediate + [?rel-linking :eacl.relationship/resource ?this-resource] + [?rel-linking :eacl.relationship/relation-name ?via-relation] + [?rel-linking :eacl.relationship/subject ?intermediate-resource] + [?rel-linking :eacl.relationship/subject-type ?intermediate-resource-type] + [?rel-linking :eacl.relationship/resource-type ?this-resource-type] + + (has-permission ?subject-type ?subject ?perm-on-related ?intermediate-resource-type ?intermediate-resource) + + [(not= ?subject ?this-resource)] + [(not= ?subject ?intermediate-resource)] + [(not= ?this-resource ?intermediate-resource)]] + + ;; Arrow permission to relation - unified schema + [(has-permission ?subject-type ?subject ?perm-name-on-this-resource ?this-resource-type ?this-resource) + + ;; Find arrow permissions that target relations + [?arrow-perm :eacl.permission/resource-type ?this-resource-type] + [?arrow-perm :eacl.permission/permission-name ?perm-name-on-this-resource] + [?arrow-perm :eacl.permission/source-relation-name ?via-relation] + [?arrow-perm :eacl.permission/target-type :relation] + [?arrow-perm :eacl.permission/target-name ?target-relation] + + ;; Find intermediate + [?rel-linking :eacl.relationship/resource ?this-resource] + [?rel-linking :eacl.relationship/relation-name ?via-relation] + [?rel-linking :eacl.relationship/subject ?intermediate-resource] + [?rel-linking :eacl.relationship/subject-type ?intermediate-resource-type] + [?rel-linking :eacl.relationship/resource-type ?this-resource-type] + + ;; Check if subject has the target relation on intermediate resource + [?target-rel :eacl.relationship/resource ?intermediate-resource] + [?target-rel :eacl.relationship/resource-type ?intermediate-resource-type] + [?target-rel :eacl.relationship/subject ?subject] + [?target-rel :eacl.relationship/subject-type ?subject-type] + [?target-rel :eacl.relationship/relation-name ?target-relation] + + [(not= ?subject ?this-resource)] + [(not= ?subject ?intermediate-resource)] + [(not= ?this-resource ?intermediate-resource)]]]) + +;(def rules-lookup-resources +; "Optimized rules for lookup-resources - subject-centric approach" +; '[;; Helper rule: find relationships from subject +; +; [(relations-between-subject-resource ?subject ?relation ?resource-type ?resource) +; [(tuple ?subject ?resource-type) ?subject+resource-type] +; [?relationship :eacl.relationship/subject+resource-type ?subject+resource-type] +; +; [?relationship :eacl.relationship/relation-name ?relation] +; [?relationship :eacl.relationship/subject ?subject] +; [?relationship :eacl.relationship/resource ?resource] +; [?relationship :eacl.relationship/resource-type ?resource-type]] +; +; [(subject-has-relationships ?subject-type ?subject ?relation ?resource-type ?resource) +; ;; Start from subject +; +; [(tuple ?subject ?relation ?resource) ?subject+relation+resource] +; [?relationship :eacl.relationship/subject+relation-name+resource ?subject+relation+resource] +; +; [?relationship :eacl.relationship/subject ?subject] +; [?relationship :eacl.relationship/resource ?resource] +; [?relationship :eacl.relationship/relation-name ?relation] +; [?relationship :eacl.relationship/subject-type ?subject-type] +; [?relationship :eacl.relationship/resource-type ?resource-type]] +; +; ;; Direct permission check - subject-centric +; [(has-permission ?subject-type ?subject ?permission ?resource-type ?resource) +; ;; Check if resource is of correct type +; ;[?resource :eacl/type ?resource-type] +; +; [(tuple ?resource-type ?permission) ?rtype+permission] +; [?perm :eacl.permission/resource-type+permission-name ?rtype+permission] +; +; ;; Check if relation grants permission +; ;[?perm :eacl.permission/resource-type ?resource-type] +; [?perm :eacl.permission/relation-name ?relation] +; ;[?perm :eacl.permission/permission-name ?permission] +; +; (subject-has-relationships ?subject-type ?subject ?relation ?resource-type ?resource)] +; +; ;; Indirect permission via intermediate resources +; [(has-permission ?subject-type ?subject ?permission ?resource-type ?resource) +; ;; Find relationships where subject can reach an intermediate +; +; ; Find relations that grant this permission: +; [(tuple ?resource-type ?permission) ?rtype+permission] +; [?perm-def :eacl.permission/resource-type+permission-name ?rtype+permission] +; [?perm-def :eacl.permission/resource-type ?resource-type] +; [?perm-def :eacl.permission/permission-name ?permission] +; [?perm-def :eacl.permission/relation-name ?rel2] +; +; (relations-between-subject-resource ?subject ?rel1 ?intermediate-type ?intermediate) +; ;(subject-has-relationships ?subject-type ?subject ?rel1 ?intermediate-type ?intermediate) +; +; ;[(tuple ?intermediate ?rel2 ?resource-type) ?intermediate+rel2+rtype] +; ;[?relationship2 :eacl.relationship/subject+relation-name+resource-type ?intermediate+rel2+rtype] +; +; ;; Find resources connected to intermediate via rel2 +; [?relationship2 :eacl.relationship/subject-type ?intermediate-type] +; [?relationship2 :eacl.relationship/subject ?intermediate] +; [?relationship2 :eacl.relationship/relation-name ?rel2] +; [?relationship2 :eacl.relationship/resource ?resource] +; [?relationship2 :eacl.relationship/resource-type ?resource-type]] +; +; ;; Verify resource type +; ;[?resource :eacl/type ?resource-type]] +; +; ;; Arrow permission - optimized for subject-centric lookup +; [(has-permission ?subject-type ?subject ?permission ?resource-type ?resource) +; ; known: subject-type ,subject, permission, resource-type. +; ;; Find arrow permissions for the target resource type and permission +; +; [(tuple ?resource-type ?permission) ?rtype+perm] +; [?arrow :eacl.arrow-permission/resource-type+permission-name ?rtype+perm] +; +; ;[?arrow :eacl.arrow-permission/resource-type ?resource-type] +; ;[?arrow :eacl.arrow-permission/permission-name ?permission] +; [?arrow :eacl.arrow-permission/source-relation-name ?via-rel] +; [?arrow :eacl.arrow-permission/target-permission-name ?target-perm] +; +; ;; Find intermediate resources linked to target resource (resource is not known here) +; ; the problem is we know via-rel, but not ?intermediate or ?resource. +; ; how to cull ?resource here. +; ; we should be able to narrow down relationships here to find the relevant ?intermediate subjects for traversal +; +; ;[(tuple ?resource-type ?via-rel) ?rtype+via-rel] +; ;[?link :eacl.relationship/resource-type+relation-name ?rtype+via-rel] +; ;[?link :eacl.relationship/resource-type+relation-name ?subject+via-rel+rtype] +; +; [?link :eacl.relationship/resource ?resource] ; this is unknown and expands. +; [?link :eacl.relationship/resource-type ?resource-type] ; this is known via arg. +; [?link :eacl.relationship/relation-name ?via-rel] ; this is known via arrow. +; +; [?link :eacl.relationship/subject ?intermediate] ; this is looked up here +; [?link :eacl.relationship/subject-type ?intermediate-type] ; this is looked up here +; +; ;; Get intermediate resource type +; ;[?intermediate :eacl/type ?intermediate-type] +; +; ;; Check if subject has target permission on intermediate (recursive) +; (has-permission ?subject-type ?subject ?target-perm ?intermediate-type ?intermediate)]]) + +(def rules-lookup-resources + ; not currently used. lookup-resources currently uses the check-permission rules, which are slow. + "Too slow. Superseded by direct index impl. + Was optimized rules for lookup-resources - subject-centric approach" + '[;; Helper rule: find relationships from subject + [(subject-has-relationships ?subject ?relation ?resource) + ;; Start from subject + [?relationship :eacl.relationship/subject ?subject] + [?relationship :eacl.relationship/relation-name ?relation] + [?relationship :eacl.relationship/resource ?resource]] + + ;; Direct permission check - subject-centric + [(has-permission ?subject-type ?subject ?permission ?resource-type ?resource) + ;; Start from subject's relationships + (subject-has-relationships ?subject ?relation ?resource) + + ;; Check if resource is of correct type + [?resource :eacl/type ?resource-type] + + ;; Check if relation grants permission + [?perm :eacl.permission/resource-type ?resource-type] + [?perm :eacl.permission/relation-name ?relation] + [?perm :eacl.permission/permission-name ?permission]] + + ;; Indirect permission via intermediate resources + [(has-permission ?subject ?permission ?resource-type ?resource) + ;; Find relationships where subject can reach an intermediate + (subject-has-relationships ?subject ?rel1 ?intermediate) + + ;; Find permission definition that grants access via relation + [?perm-def :eacl.permission/resource-type ?resource-type] + [?perm-def :eacl.permission/permission-name ?permission] + [?perm-def :eacl.permission/relation-name ?rel2] + + ;; Find resources connected to intermediate via rel2 + [?relationship2 :eacl.relationship/subject ?intermediate] + [?relationship2 :eacl.relationship/relation-name ?rel2] + [?relationship2 :eacl.relationship/resource ?resource] + + ;; Verify resource type + [?resource :eacl/type ?resource-type]] + + ;; Arrow permission - optimized for subject-centric lookup + [(has-permission ?subject ?permission ?resource-type ?resource) + ;; Find arrow permissions for the target resource type and permission + [?arrow :eacl.arrow-permission/resource-type ?resource-type] + [?arrow :eacl.arrow-permission/permission-name ?permission] + [?arrow :eacl.arrow-permission/source-relation-name ?via-rel] + [?arrow :eacl.arrow-permission/target-permission-name ?target-perm] + + ;; Find resources of target type + [?resource :eacl/type ?resource-type] + + ;; Find intermediate resources linked to target resource + [?link :eacl.relationship/resource ?resource] + [?link :eacl.relationship/relation-name ?via-rel] + [?link :eacl.relationship/subject ?intermediate] + + ;; Get intermediate resource type + [?intermediate :eacl/type ?intermediate-type] + + ;; Check if subject has target permission on intermediate (recursive) + (has-permission ?subject ?target-perm ?intermediate-type ?intermediate)]]) \ No newline at end of file diff --git a/modules/eacl-datomic/src/eacl/datomic/rules/optimized_old.clj b/modules/eacl-datomic/src/eacl/datomic/rules/optimized_old.clj new file mode 100644 index 000000000..26ffe2d05 --- /dev/null +++ b/modules/eacl-datomic/src/eacl/datomic/rules/optimized_old.clj @@ -0,0 +1,225 @@ +(ns eacl.datomic.rules.optimized-old + "Optimized Datalog rules for EACL performance improvements") + +(def check-permission-rules + "Optimized rules for can? - reordered clauses and better tuple usage" + '[;; Optimized reachability using tuples + [(reachable ?resource ?subject) + ;; Direct relationship - most common case + [(tuple ?resource ?subject) ?resource+subject] + [?relationship :eacl.relationship/resource+subject ?resource+subject]] + + [(reachable ?resource ?subject) + ;; Indirect relationship - use tuple for first hop + [(tuple ?resource ?mid) ?resource+mid] + [?relationship :eacl.relationship/resource+subject ?resource+mid] + ;; Only traverse if needed + (reachable ?mid ?subject)] + + ;; Direct permission - optimized clause ordering + [(has-permission ?subject ?permission-name ?resource) + ;; Get resource type first + [?resource :resource/type ?resource-type] + + ;; Find relationships for this resource + [?relationship :eacl.relationship/resource ?resource] + [?relationship :eacl.relationship/subject ?subject] + [?relationship :eacl.relationship/relation-name ?relation-name] + + ;; Check permission using tuple + [(tuple ?resource-type ?relation-name ?permission-name) ?perm-tuple] + [?perm-def :eacl.permission/resource-type+relation-name+permission-name ?perm-tuple] + + ;; Exclude self-references + [(not= ?subject ?resource)]] + + ;; Indirect permission inheritance - optimized + [(has-permission ?subject ?permission-name ?resource) + ;; Get resource type first (we already have the resource) + [?resource :resource/type ?resource-type] + + ;; Find permission definitions for this resource type + [?perm-def :eacl.permission/resource-type ?resource-type] + [?perm-def :eacl.permission/permission-name ?permission-name] + [?perm-def :eacl.permission/relation-name ?relation-name] + + ;; Find structural relationships where resource is the subject + [?structural-rel :eacl.relationship/subject ?resource] + [?structural-rel :eacl.relationship/relation-name ?relation-name] + [?structural-rel :eacl.relationship/resource ?target] + + ;; Check reachability last + (reachable ?target ?subject) + [(not= ?subject ?resource)]] + + ;; Arrow permission - optimized + [(has-permission ?subject ?perm-name-on-this-resource ?this-resource) + ;; Get resource type from the resource we already have + [?this-resource :resource/type ?this-resource-type] + + ;; Find arrow permission definitions + [?arrow-perm :eacl.arrow-permission/resource-type ?this-resource-type] + [?arrow-perm :eacl.arrow-permission/permission-name ?perm-name-on-this-resource] + [?arrow-perm :eacl.arrow-permission/source-relation-name ?via-relation] + [?arrow-perm :eacl.arrow-permission/target-permission-name ?perm-on-related] + + ;; Find intermediate resource + [?rel-linking :eacl.relationship/resource ?this-resource] + [?rel-linking :eacl.relationship/relation-name ?via-relation] + [?rel-linking :eacl.relationship/subject ?intermediate-resource] + + ;; Recursive permission check + (has-permission ?subject ?perm-on-related ?intermediate-resource) + + ;; Safety checks + [(not= ?subject ?this-resource)] + [(not= ?subject ?intermediate-resource)] + [(not= ?this-resource ?intermediate-resource)]]]) + +(def rules-lookup-subjects + "Optimized rules for lookup-subjects" + '[;; Reachability rules remain the same + [(reachable ?resource ?subject) + [(tuple ?resource ?subject) ?resource+subject] + [?relationship :eacl.relationship/resource+subject ?resource+subject]] + + [(reachable ?resource ?subject) + [(tuple ?resource ?mid) ?resource+mid] + [?relationship :eacl.relationship/resource+subject ?resource+mid] + (reachable ?mid ?subject)] + + ;; Direct permission check - optimized for known resource + [(has-permission ?subject-type ?subject ?permission-name ?resource) + ;; Get resource type (we already have resource entity) + [?resource :resource/type ?resource-type] + + ;; Find relationships for this resource + [?relationship :eacl.relationship/resource ?resource] + [?relationship :eacl.relationship/subject ?subject] + [?relationship :eacl.relationship/relation-name ?relation-name] + + ;; Check subject type + [?subject :resource/type ?subject-type] + + ;; Check permission using tuple + [(tuple ?resource-type ?relation-name ?permission-name) ?perm-tuple] + [?perm-def :eacl.permission/resource-type+relation-name+permission-name ?perm-tuple] + + [(not= ?subject ?resource)]] + + ;; Indirect permission inheritance + [(has-permission ?subject-type ?subject ?permission-name ?resource) + [?resource :resource/type ?resource-type] + + ;; Find permission definitions + [?perm-def :eacl.permission/resource-type ?resource-type] + [?perm-def :eacl.permission/permission-name ?permission-name] + [?perm-def :eacl.permission/relation-name ?relation-name] + + ;; Find structural relationships + [?structural-rel :eacl.relationship/subject ?resource] + [?structural-rel :eacl.relationship/relation-name ?relation-name] + [?structural-rel :eacl.relationship/resource ?target] + + (reachable ?target ?subject) + [?subject :resource/type ?subject-type] + [(not= ?subject ?resource)]] + + ;; Arrow permission + [(has-permission ?subject-type ?subject ?perm-name-on-this-resource ?this-resource) + [?this-resource :resource/type ?this-resource-type] + + ;; Find arrow permissions + [?arrow-perm :eacl.arrow-permission/resource-type ?this-resource-type] + [?arrow-perm :eacl.arrow-permission/permission-name ?perm-name-on-this-resource] + [?arrow-perm :eacl.arrow-permission/source-relation-name ?via-relation] + [?arrow-perm :eacl.arrow-permission/target-permission-name ?perm-on-related] + + ;; Find intermediate + [?rel-linking :eacl.relationship/resource ?this-resource] + [?rel-linking :eacl.relationship/relation-name ?via-relation] + [?rel-linking :eacl.relationship/subject ?intermediate-resource] + + (has-permission ?subject-type ?subject ?perm-on-related ?intermediate-resource) + + [(not= ?subject ?this-resource)] + [(not= ?subject ?intermediate-resource)] + [(not= ?this-resource ?intermediate-resource)]]]) + +(def rules-lookup-resources + "Optimized rules for lookup-resources - subject-centric approach" + '[;; Helper rule: find relationships from subject + [(subject-has-relationships ?subject ?relation ?resource) + ;; Start from subject + + ;[(tuple ?subject ?relation ?resource) ?subject+relation+resource] + ;[?relationship :eacl.relationship/] + + [?relationship :eacl.relationship/subject ?subject] + [?relationship :eacl.relationship/relation-name ?relation] + [?relationship :eacl.relationship/resource ?resource]] + + ;; Direct permission check - subject-centric + [(has-permission ?subject ?permission ?resource-type ?resource) + ;; Start from subject's relationships + (subject-has-relationships ?subject ?relation ?resource) + + ;; Check if resource is of correct type + [?resource :resource/type ?resource-type] + + ;; Check if relation grants permission + [?perm :eacl.permission/resource-type ?resource-type] + [?perm :eacl.permission/relation-name ?relation] + [?perm :eacl.permission/permission-name ?permission]] + + ;; Indirect permission via intermediate resources + [(has-permission ?subject ?permission ?resource-type ?resource) + ;; Find relationships where subject can reach an intermediate + (subject-has-relationships ?subject ?rel1 ?intermediate) + + ;; Find permission definition that grants access via relation + [?perm-def :eacl.permission/resource-type ?resource-type] + [?perm-def :eacl.permission/permission-name ?permission] + [?perm-def :eacl.permission/relation-name ?rel2] + + ;; Find resources connected to intermediate via rel2 + [?relationship2 :eacl.relationship/subject ?intermediate] + [?relationship2 :eacl.relationship/relation-name ?rel2] + [?relationship2 :eacl.relationship/resource ?resource] + + ;; Verify resource type + [?resource :resource/type ?resource-type]] + + ;; Arrow permission - optimized for subject-centric lookup + [(has-permission ?subject ?permission ?resource-type ?resource) + ; known: subject, permission, resource-type. + ;; Find arrow permissions for the target resource type and permission + + [(tuple ?resource-type ?permission) ?rtype+perm] + [?arrow :eacl.arrow-permission/resource-type+permission-name ?rtype+perm] + + ;[?arrow :eacl.arrow-permission/resource-type ?resource-type] + ;[?arrow :eacl.arrow-permission/permission-name ?permission] + [?arrow :eacl.arrow-permission/source-relation-name ?via-rel] + [?arrow :eacl.arrow-permission/target-permission-name ?target-perm] + + ;; Find resources of target type + [?resource :resource/type ?resource-type] ; this looks slow. + + ;; Find intermediate resources linked to target resource (resource is not known here) + ; the problem is we know via-rel, but not ?intermediate or ?resource. + ; how to cull ?resource here. + ; we should be able to narrow down relationships here to find the relevant ?intermediate subjects for traversal + + ;[(tuple ?subject ?via-rel) ?subject+via-rel] + ;[?link :eacl.relationship/subject+relation-name ?subject+via-rel] + + [?link :eacl.relationship/relation-name ?via-rel] + [?link :eacl.relationship/resource ?resource] + [?link :eacl.relationship/subject ?intermediate] + + ;; Get intermediate resource type + [?intermediate :resource/type ?intermediate-type] + + ;; Check if subject has target permission on intermediate (recursive) + (has-permission ?subject ?target-perm ?intermediate-type ?intermediate)]]) \ No newline at end of file diff --git a/modules/eacl-datomic/src/eacl/datomic/schema.clj b/modules/eacl-datomic/src/eacl/datomic/schema.clj new file mode 100644 index 000000000..4cf854db6 --- /dev/null +++ b/modules/eacl-datomic/src/eacl/datomic/schema.clj @@ -0,0 +1,279 @@ +(ns eacl.datomic.schema + (:require [clojure.set] + [datomic.api :as d] + [com.rpl.specter :as S] + [eacl.schema.model :as model] + [eacl.spicedb.parser :as parser] + [eacl.datomic.impl.indexed :as impl.indexed])) + +; should these Malli specs be in a separate namespace, e.g. specs? +; might be confused for Datomic fn's like Relation / Permission in impl. base. +; Ideally Datomic impl. should reuse these. + +(def Relation + [:map + [:eacl.relation/resource-type :keyword] + [:eacl.relation/subject-type :keyword] + [:eacl.relation/relation-name :keyword]]) + +; todo: fix the Malli schema for unified Permission. +;(def DirectPermission +; [:map +; [:eacl.permission/resource-type :keyword] +; [:eacl.permission/relation-name :keyword] +; [:eacl.permission/permission-name :keyword] +; +; [:eacl.relation/subject-type :keyword] +; [:eacl.relation/relation-name :keyword]]) + +;(def ArrowPermission +; [:map +; [:eacl.arrow-permission/resource-type :keyword] +; [:eacl.arrow-permission/source-relation-name :keyword] +; [:eacl.arrow-permission/target-permission-name :keyword] +; [:eacl.arrow-permission/permission-name :keyword]]) + +;(def Permission +; [:or DirectPermission ArrowPermission]) + +(def v7-schema + [; :eacl/id is now optional. + {:db/ident :eacl/id ; todo: figure out how to support :id, :object/id or :spice/id of different types. + :db/doc "Unique String ID to match SpiceDB Object IDs." + :db/valueType :db.type/string + :db/unique :db.unique/identity + :db/cardinality :db.cardinality/one} + + {:db/ident :eacl/schema-string + :db/doc "Stores the SpiceDB schema string." + :db/valueType :db.type/string + :db/cardinality :db.cardinality/one} + + ;; Relations + {:db/ident :eacl.relation/resource-type + :db/doc "EACL Relation: Resource Type" + :db/valueType :db.type/keyword + :db/cardinality :db.cardinality/one + :db/index true} + + {:db/ident :eacl.relation/relation-name + :db/doc "EACL Relation Name (keyword)" + :db/valueType :db.type/keyword + :db/cardinality :db.cardinality/one + :db/index true} + + {:db/ident :eacl.relation/subject-type + :db/doc "EACL Relation: Subject Type" + :db/valueType :db.type/keyword + :db/cardinality :db.cardinality/one + :db/index true} + + ; Relation Indices (these are cheap because Relations are sparse) + + {:db/ident :eacl.relation/resource-type+relation-name+subject-type + :db/doc "EACL Relation: Unique identity tuple enforce uniqueness of Resource Type + Relation Name + Subject Type" + :db/valueType :db.type/tuple + :db/tupleAttrs [:eacl.relation/resource-type + :eacl.relation/relation-name + :eacl.relation/subject-type] + :db/cardinality :db.cardinality/one + :db/unique :db.unique/identity} + + ;; Unified Permissions Schema + {:db/ident :eacl.permission/resource-type + :db/doc "EACL Permission: Resource Type" + :db/valueType :db.type/keyword + :db/cardinality :db.cardinality/one + :db/index true} + + {:db/ident :eacl.permission/permission-name + :db/doc "EACL Permission: Permission Name" + :db/valueType :db.type/keyword + :db/cardinality :db.cardinality/one + :db/index true} + + {:db/ident :eacl.permission/source-relation-name + :db/doc "EACL Permission: Source relation for arrow permissions (optional - not present for direct permissions)" + :db/valueType :db.type/keyword + :db/cardinality :db.cardinality/one + :db/index true} + + {:db/ident :eacl.permission/target-type + :db/doc "EACL Permission: Target type (:relation or :permission)" + :db/valueType :db.type/keyword + :db/cardinality :db.cardinality/one + :db/index true} + + {:db/ident :eacl.permission/target-name + :db/doc "EACL Permission: Target name (relation name or permission name)" + :db/valueType :db.type/keyword + :db/cardinality :db.cardinality/one + :db/index true} + + ; Permission Indices + {:db/ident :eacl.permission/resource-type+permission-name + :db/doc "EACL Permission: Index for finding all permissions on a resource type" + :db/valueType :db.type/tuple + :db/tupleAttrs [:eacl.permission/resource-type + :eacl.permission/permission-name] + :db/cardinality :db.cardinality/one + :db/index true} + + ;; Added: Enumeration indices for efficient arrow permission lookup + {:db/ident :eacl.permission/resource-type+source-relation-name+target-type+permission-name + :db/doc "EACL Permission: Index for enumerating permission-type arrows" + :db/valueType :db.type/tuple + :db/tupleAttrs [:eacl.permission/resource-type + :eacl.permission/source-relation-name + :eacl.permission/target-type + :eacl.permission/permission-name] + :db/cardinality :db.cardinality/one + :db/index true} + + {:db/ident :eacl.permission/resource-type+source-relation-name+target-type+target-name + :db/doc "EACL Permission: Index for enumerating relation-type arrows" + :db/valueType :db.type/tuple + :db/tupleAttrs [:eacl.permission/resource-type + :eacl.permission/source-relation-name + :eacl.permission/target-type + :eacl.permission/target-name] + :db/cardinality :db.cardinality/one + :db/index true} + + {:db/ident :eacl.permission/resource-type+source-relation-name+target-type+target-name+permission-name + :db/doc "EACL Permission: Full unique identity tuple to prevent duplicate permissions." + ; I suspect the tuple order can be improved for faster permission enumeration. + :db/valueType :db.type/tuple + :db/tupleAttrs [:eacl.permission/resource-type + :eacl.permission/source-relation-name + :eacl.permission/target-type + :eacl.permission/target-name + :eacl.permission/permission-name] + :db/cardinality :db.cardinality/one + :db/unique :db.unique/identity} + + ;; v7 Relationships: forward and reverse tuple indexes only. + {:db/ident :eacl.v7.relationship/subject-type+relation+resource-type+resource + :db/doc "EACL v7 relationship tuple from subject to resource." + :db/valueType :db.type/tuple + :db/tupleTypes [:db.type/keyword + :db.type/ref + :db.type/keyword + :db.type/ref] + :db/cardinality :db.cardinality/many + :db/index true} + + {:db/ident :eacl.v7.relationship/resource-type+relation+subject-type+subject + :db/doc "EACL v7 reverse relationship tuple from resource to subject." + :db/valueType :db.type/tuple + :db/tupleTypes [:db.type/keyword + :db.type/ref + :db.type/keyword + :db.type/ref] + :db/cardinality :db.cardinality/many + :db/index true}]) + +(def v6-schema + "Compatibility alias while tests and callers move to the v7 name." + v7-schema) + +(defn count-relationships-using-relation + "Counts v7 forward relationship tuples that reference the given relation." + [db {:eacl.relation/keys [resource-type relation-name subject-type]}] + {:pre [(keyword? resource-type) + (keyword? relation-name) + (keyword? subject-type)]} + (let [relation-id (str "eacl.relation:" resource-type ":" relation-name ":" subject-type) + relation-eid (d/entid db [:eacl/id relation-id])] + (if-not relation-eid + 0 + (reduce (fn [n _] (inc n)) + 0 + (d/index-range db + :eacl.v7.relationship/subject-type+relation+resource-type+resource + [subject-type relation-eid resource-type 0] + [subject-type relation-eid resource-type Long/MAX_VALUE]))))) + +(defn read-relations + "Enumerates all EACL Relation schema entities in DB and returns pull maps." + [db] + (d/q '[:find [(pull ?relation [:eacl/id + :eacl.relation/subject-type + :eacl.relation/resource-type + :eacl.relation/relation-name]) ...] + :where + [?relation :eacl.relation/relation-name ?relation-name]] + db)) + +(defn read-permissions + "Enumerates all EACL permission schema entities in DB and returns maps." + [db] + (d/q '[:find [(pull ?perm [:eacl/id + :eacl.permission/resource-type + :eacl.permission/permission-name + :eacl.permission/source-relation-name + :eacl.permission/target-type + :eacl.permission/target-name]) ...] + :where + [?perm :eacl.permission/permission-name]] + db)) + +(defn read-schema + "Enumerates all EACL permission schema entities in DB and returns maps." + ; todo: unparse into SpiceDB string schema if desired. + [db & [_format]] + {:relations (read-relations db) + :permissions (read-permissions db)}) + +(def validate-schema-references model/validate-schema-references) + +; now we have to do a diff of relations and permissions +; we can safely delete permissions because will simply resolve +; but when deleting Relations, we need to check if there are any relationships +; can we use the existing read-relationships internals for this? + +(def calc-set-deltas model/calc-set-deltas) + +(def compare-schema model/compare-schema) + +(defn write-schema! + "Computes delta between existing schema and + new schema, checks for any orphaned relationships on retracted schema, + produces tx-ops and applies. + + Throws if schema is invalid (operator validation, reference validation, orphan check)." + [conn schema-string] + (let [new-schema-map (parser/->eacl-schema (parser/parse-schema schema-string)) + ;; Validate schema references before proceeding (ADR 012 requirement) + _ (validate-schema-references new-schema-map) + db (d/db conn) + existing-schema (read-schema db) + deltas (compare-schema existing-schema new-schema-map) + {:keys [relations permissions]} deltas + relation-retractions (:retractions relations) + permission-retractions (:retractions permissions)] + + ;; Check for orphaned relationships + (doseq [rel relation-retractions] + (let [cnt (count-relationships-using-relation db rel)] + (when (pos? cnt) + (throw (ex-info (str "Cannot delete relation " (:eacl.relation/relation-name rel) + " because it is used by " cnt " relationships.") + {:relation rel :count cnt}))))) + + ;; Transact changes + (let [tx-data (concat + ;; Additions + (:additions relations) + (:additions permissions) + ;; Retractions + (for [rel relation-retractions] + [:db.fn/retractEntity [:eacl/id (:eacl/id rel)]]) + (for [perm permission-retractions] + [:db.fn/retractEntity [:eacl/id (:eacl/id perm)]]) + ;; Store schema string + [{:eacl/id "schema-string" + :eacl/schema-string schema-string}])] + @(d/transact conn tx-data) + (impl.indexed/evict-permission-paths-cache!) + deltas))) diff --git a/modules/eacl-datomic/test/eacl/bench/pagination_test.clj b/modules/eacl-datomic/test/eacl/bench/pagination_test.clj new file mode 100644 index 000000000..b9dc645f0 --- /dev/null +++ b/modules/eacl-datomic/test/eacl/bench/pagination_test.clj @@ -0,0 +1,264 @@ +(ns eacl.bench.pagination-test + "Multi-path pagination benchmarks for regression detection. + + Run with: clojure -M:bench + These tests are excluded from normal test runs via ^:benchmark metadata. + + Tests a 4-path permission graph (server.view = account->admin + team->admin + vpc->admin + shared_admin) + which exercises the cursor-tree merge algorithm with multiple divergent arrow paths." + (:require [clojure.test :refer [deftest testing is]] + [datomic.api :as d] + [eacl.core :as eacl] + [eacl.datomic.core :as spiceomic] + [eacl.datomic.impl :as impl :refer [Relationship]] + [eacl.datomic.schema :as schema] + [eacl.datomic.datomic-helpers :refer [with-mem-conn]] + [eacl.datomic.fixtures :refer [->user ->account ->server ->team ->vpc ->platform]])) + +;; --- Schema --- + +(def multipath-schema-dsl + "definition user {} + + definition platform { + relation super_admin: user + } + + definition account { + relation owner: user + relation platform: platform + + permission admin = owner + platform->super_admin + } + + definition team { + relation account: account + relation leader: user + + permission admin = account->admin + leader + } + + definition vpc { + relation account: account + relation shared_admin: user + + permission admin = account->admin + shared_admin + } + + definition server { + relation account: account + relation team: team + relation vpc: vpc + relation shared_admin: user + + permission view = account->admin + team->admin + vpc->admin + shared_admin + permission admin = account->admin + shared_admin + }") + +(def basic-attrs + [{:db/ident :server/name, :db/cardinality :db.cardinality/one, :db/valueType :db.type/string, :db/index true} + {:db/ident :team/name, :db/cardinality :db.cardinality/one, :db/valueType :db.type/string, :db/index true} + {:db/ident :vpc/name, :db/cardinality :db.cardinality/one, :db/valueType :db.type/string, :db/index true}]) + +(defn- tx-relationships + [db relationships] + (mapcat #(impl/tx-relationship db %) relationships)) + +;; --- Seeding --- + +(defn seed-multipath! + "Seeds a multi-path permission graph. Returns the acl client." + [conn {:keys [num-accounts teams-per-acct vpcs-per-acct servers-per-acct]}] + (let [acl (spiceomic/make-client conn {:entity->object-id (fn [ent] (:eacl/id ent)) + :object-id->ident (fn [obj-id] [:eacl/id obj-id])})] + @(d/transact conn basic-attrs) + @(d/transact conn schema/v6-schema) + (eacl/write-schema! acl multipath-schema-dsl) + + ;; Platform + super-user + test user + @(d/transact conn + (concat + [{:db/id "platform", :db/ident :test/platform, :eacl/id "platform"} + {:db/id "super-user", :db/ident :user/super-user, :eacl/id "super-user"} + {:db/id "user-1", :db/ident :test/user1, :eacl/id "user-1"}] + (tx-relationships (d/db conn) + [(Relationship (->user "super-user") :super_admin (->platform "platform"))]))) + + ;; Seed accounts with teams, vpcs, servers + (let [account-uuids (repeatedly num-accounts d/squuid)] + (doseq [[n account-uuid] (map-indexed vector account-uuids)] + (let [account-tempid (d/tempid :db.part/user) + owner-tempid (d/tempid :db.part/user) + + team-data (for [t (range teams-per-acct)] + (let [team-tempid (d/tempid :db.part/user) + leader-tempid (d/tempid :db.part/user)] + {:team-tempid team-tempid + :txes (concat + [{:db/id team-tempid, :eacl/id (str (d/squuid)), :team/name (str "Team " t)} + {:db/id leader-tempid, :eacl/id (str (d/squuid))}] + (tx-relationships (d/db conn) + [(Relationship (->account account-tempid) :account (->team team-tempid)) + (Relationship (->user leader-tempid) :leader (->team team-tempid))]))})) + + vpc-data (for [v (range vpcs-per-acct)] + (let [vpc-tempid (d/tempid :db.part/user) + sa-tempid (d/tempid :db.part/user)] + {:vpc-tempid vpc-tempid + :txes (concat + [{:db/id vpc-tempid, :eacl/id (str (d/squuid)), :vpc/name (str "VPC " v)} + {:db/id sa-tempid, :eacl/id (str (d/squuid))}] + (tx-relationships (d/db conn) + [(Relationship (->account account-tempid) :account (->vpc vpc-tempid)) + (Relationship (->user sa-tempid) :shared_admin (->vpc vpc-tempid))]))})) + + team-tempids (mapv :team-tempid team-data) + vpc-tempids (mapv :vpc-tempid vpc-data) + + server-txes (for [s (range servers-per-acct)] + (let [server-tempid (d/tempid :db.part/user)] + (concat + [{:db/id server-tempid, :server/name (str "Server " (d/squuid)), :eacl/id (str (d/squuid))}] + (tx-relationships (d/db conn) + [(Relationship (->account account-tempid) :account (->server server-tempid)) + (Relationship (->team (nth team-tempids (mod s teams-per-acct))) :team (->server server-tempid)) + (Relationship (->vpc (nth vpc-tempids (mod s vpcs-per-acct))) :vpc (->server server-tempid))])))) + + account-txes (concat + [{:db/id account-tempid, :eacl/id (str account-uuid)} + {:db/id owner-tempid, :eacl/id (str (d/squuid))}] + (tx-relationships (d/db conn) + [(Relationship (->platform :test/platform) :platform (->account account-tempid)) + (Relationship (->user owner-tempid) :owner (->account account-tempid))])) + + all-txes (concat account-txes + (mapcat :txes team-data) + (mapcat :txes vpc-data) + (apply concat server-txes))] + @(d/transact conn all-txes)))) + + ;; Give user-1 ownership of first 2 accounts + (let [db (d/db conn) + first-accounts (->> (d/q '[:find [?aid ...] + :where [?a :eacl/id ?aid]] + db) + sort + (take 2))] + (doseq [aid first-accounts] + @(d/transact conn + (tx-relationships (d/db conn) + [(Relationship (->user :test/user1) :owner (->account [:eacl/id aid]))])))) + + acl)) + +;; --- Timing utilities --- + +(defn- run-timed + "Runs f n times, returns vector of elapsed times in ms." + [n f] + (mapv (fn [_] + (let [start (System/nanoTime) + _ (f) + end (System/nanoTime)] + (/ (double (- end start)) 1e6))) + (range n))) + +(defn- median [coll] + (let [sorted (sort coll) + n (count sorted) + mid (quot n 2)] + (if (odd? n) + (nth sorted mid) + (/ (+ (nth sorted (dec mid)) (nth sorted mid)) 2.0)))) + +(defn- percentile [coll p] + (let [sorted (sort coll) + idx (min (dec (count sorted)) + (int (Math/ceil (* (/ p 100.0) (count sorted)))))] + (nth sorted idx))) + +;; --- Regression thresholds --- +;; +;; With 15k servers and 4 arrow paths: +;; - cursor-tree branch: ~2-10ms per page (depending on hardware) +;; - lazy-merge-sort regression: ~30-70ms per page (6x slower) +;; +;; Thresholds are generous to account for CI/slow hardware, +;; but will catch a 6x algorithmic regression. + +(def ^:private first-page-threshold-ms 75) +(def ^:private per-page-threshold-ms 50) + +;; --- Benchmark config --- + +(def ^:private bench-config + {:num-accounts 30 + :teams-per-acct 4 + :vpcs-per-acct 2 + :servers-per-acct 500}) + +(def ^:private warmup-iterations 20) +(def ^:private bench-iterations 30) +(def ^:private pagination-iterations 10) +(def ^:private pages-per-run 20) + +;; --- Tests --- + +(deftest ^:benchmark multipath-pagination-benchmark + (testing "Multi-path pagination performance (4 arrow paths)" + (with-mem-conn [conn []] + (let [total-servers (* (:num-accounts bench-config) (:servers-per-acct bench-config)) + _ (println (format "\nSeeding %d servers (%d accounts x %d servers, %d teams/acct, %d vpcs/acct)..." + total-servers + (:num-accounts bench-config) + (:servers-per-acct bench-config) + (:teams-per-acct bench-config) + (:vpcs-per-acct bench-config))) + acl (seed-multipath! conn bench-config) + _ (println "Seeding complete.") + + subject (->user "super-user") + base-query {:subject subject + :permission :view + :resource/type :server + :cursor nil + :limit 50}] + + (testing "first page lookup (limit=50)" + ;; Warmup JIT + (run-timed warmup-iterations #(eacl/lookup-resources acl base-query)) + + (let [times (run-timed bench-iterations #(eacl/lookup-resources acl base-query)) + med (median times) + p95 (percentile times 95)] + (println (format "First page (limit=50): median=%.2fms, p95=%.2fms, min=%.2fms, max=%.2fms" + med p95 (apply min times) (apply max times))) + (is (< med first-page-threshold-ms) + (format "REGRESSION: First page median %.2fms exceeds %dms threshold" + med first-page-threshold-ms)))) + + (testing "multi-page pagination" + (let [times (run-timed pagination-iterations + (fn [] + (loop [cursor nil, page 0] + (when (< page pages-per-run) + (let [result (eacl/lookup-resources acl (assoc base-query :cursor cursor))] + (recur (:cursor result) (inc page))))))) + med (median times) + per-page (/ med pages-per-run)] + (println (format "Pagination (%d pages): median=%.2fms total (%.2fms/page), min=%.2fms, max=%.2fms" + pages-per-run med per-page (apply min times) (apply max times))) + (is (< per-page per-page-threshold-ms) + (format "REGRESSION: Per-page median %.2fms exceeds %dms threshold" + per-page per-page-threshold-ms)))) + + (testing "pagination correctness" + (let [page1 (eacl/lookup-resources acl base-query) + page2 (eacl/lookup-resources acl (assoc base-query :cursor (:cursor page1)))] + (is (= 50 (count (:data page1))) "First page should return exactly limit results") + (is (= 50 (count (:data page2))) "Second page should return exactly limit results") + (is (some? (:cursor page1)) "First page should have a cursor for next page") + (let [ids1 (set (map :id (:data page1))) + ids2 (set (map :id (:data page2)))] + (is (empty? (clojure.set/intersection ids1 ids2)) + "Pages should not have overlapping results")))))))) diff --git a/modules/eacl-datomic/test/eacl/benchmark_test.clj b/modules/eacl-datomic/test/eacl/benchmark_test.clj new file mode 100644 index 000000000..63cbdf0b9 --- /dev/null +++ b/modules/eacl-datomic/test/eacl/benchmark_test.clj @@ -0,0 +1,403 @@ +;(ns eacl.benchmark-test +; (:require [criterium.core :as crit] +; [eacl.core :as eacl] +; [eacl.datomic.core :as spiceomic] +; ; [eacl.datomic.impl-base :as base :refer [Relation Relationship Permission]] +; [eacl.datomic.impl :as impl :refer [Relation Relationship Permission]] +; [eacl.datomic.schema :as schema] +; [datomic.api :as d] +; [eacl.datomic.fixtures :as fixtures :refer [->platform ->account ->user ->server]] +; [clojure.test :as t :refer [deftest testing is]] +; [clojure.tools.logging :as log])) +; +;;(defn rand-subject []) +; +;(defn tx! [conn tx-data] +; ;(prn tx-data) +; @(d/transact conn tx-data)) +; +;(defn ids->tempid-map [uuid-coll] +; (->> uuid-coll +; (reduce (fn [acc uuid] +; (assoc acc uuid (d/tempid :db.part/user))) +; {}))) +; +;(defn make-account-user-txes [account-tempid n] +; (let [user-uuids (repeatedly n d/squuid) +; user-uuid->tempid (ids->tempid-map user-uuids)] +; (for [user-uuid user-uuids] +; (let [user-tempid (user-uuid->tempid user-uuid)] +; [{:db/id user-tempid +; :eacl/id (str user-uuid) +; :user/account account-tempid} ; only to police permission checks. +; (Relationship (->user user-tempid) +; :owner +; (->account account-tempid))])))) +; +;(defn make-account-server-txes [account-tempid n] +; (let [server-uuids (repeatedly n d/squuid) +; server-uuid->tempid (ids->tempid-map server-uuids)] +; +; (for [server-uuid server-uuids] +; (let [server-tempid (server-uuid->tempid server-uuid)] +; [{:db/id server-tempid +; :eacl/id (str server-uuid) +; :server/account account-tempid ; only to police permission checks. +; :server/name (str "Servers " server-uuid)} +; (Relationship (->account account-tempid) :account (->server server-tempid))])))) +; +;(defn make-account-txes [{:keys [num-users num-servers]} account-uuid] +; (let [account-tempid (d/tempid :db.part/user) +; account-txes [{:db/id account-tempid +; :eacl/id (str account-uuid)} +; (Relationship (->platform [:eacl/id "platform"]) :platform (->account account-tempid))] +; user-txes (make-account-user-txes account-tempid num-users) +; server-txes (make-account-server-txes account-tempid num-servers)] +; (concat account-txes (flatten user-txes) (flatten server-txes)))) +; +;(defn server->user-ids [db server-id] +; (d/q '[:find [?user-id ...] +; :in $ ?server-id +; :where +; [?server :eacl/id ?server-id] +; [?server :server/account ?account] +; [?user :user/account ?account] +; [?user :eacl/id ?user-id]] +; db server-id)) +; +;(defn setup-benchmark [db] +; {:accounts (d/q '[:find [?account-id ...] +; :where +; [?server :server/account ?account] +; [?account :eacl/id ?account-id]] +; db) +; :users (d/q '[:find [?user-id ...] +; :where +; [?user :user/account ?account] +; [?user :eacl/id ?user-id]] +; db) +; :servers (d/q '[:find [?server-id ...] +; :where +; [?server :server/account ?account] +; [?server :eacl/id ?server-id]] +; db)}) +; +;(defn run-benchmark [!counter client {:keys [accounts users servers]}] +; ; now we cross-check each user for server and police that the value is correct +; ; do we need to shuffle these for accurate test? +; (doall (for [server-id servers +; user-id users] +; (do +; (swap! !counter inc) +; [user-id server-id (eacl/can? client (->user user-id) :view (->server server-id))])))) +; +;(defn check-results [server->user-set matrix] +; (for [[user-id server-id actual] matrix +; :let [user-set (server->user-set server-id) +; expected (contains? user-set server-id)]] +; [actual expected])) +; +;(defn rand-user [db] +; (d/q '[:find (rand ?user-uuid) . +; :in $ +; :where +; [?user :user/account ?account] +; [?user :eacl/id ?user-uuid]] +; db)) +; +;(defn rand-server [db] +; (d/q '[:find (rand ?server-uuid) . +; :in $ +; :where +; [?server :server/account ?account] +; [?server :eacl/id ?server-uuid]] +; db)) +; +;(deftest eacl-benchmarks +; ; todo switch to with-mem-conn. +; ;(def datomic-uri "datomic:dev://localhost:4597/eacl-benchmark") +; +; (comment +; (def datomic-uri "datomic:mem://mem-eacl-benchmark") +; (d/delete-database datomic-uri) +; (d/create-database datomic-uri) +; (def conn (d/connect datomic-uri)) +; (.release conn) +; #_[]) +; +; (comment +; +; (testing "Transact EACL Datomic Schema" +; (tx! conn (concat schema/v5-schema))) +; +; (testing "Transact a realistic EACL Permission Schema" +; (tx! conn fixtures/base-fixtures)) +; +; (testing "some schema to police our data" +; (tx! conn [{:db/ident :server/name +; :db/doc "Just to add some real data into the mix." +; :db/cardinality :db.cardinality/one +; :db/valueType :db.type/string +; :db/index true} +; +; {:db/ident :user/account +; :db/cardinality :db.cardinality/many +; :db/valueType :db.type/ref +; :db/index true} +; +; {:db/ident :server/account +; :db/cardinality :db.cardinality/one +; :db/valueType :db.type/ref +; :db/index true}])) +; +; (def test-account (d/q '[:find (rand ?account-uuid) . +; :where +; [?server :server/account ?account] +; [?account :eacl/id ?account-uuid]] +; (d/db conn))) +; +; test-account +; +; (def test-user (d/q '[:find (rand ?user-uuid) . +; :in $ ?account-uuid +; :where +; [?user :user/account ?account] +; [?user :eacl/id ?user-uuid]] +; (d/db conn) test-account)) +; +; (def client (spiceomic/make-client conn {})) +; +; ;; Add platform relations for all accounts: +; +; (let [platform-id (d/entid (d/db conn) [:eacl/id "platform"])] +; (->> (d/q '[:find [?account ...] +; :where [?server :server/account ?account]] +; (d/db conn)) +; (map (fn [acc] +; (Relationship (->platform platform-id) :platform (->account acc)))) +; (d/transact conn) +; (deref))) +; +; (time (count (:data (eacl/lookup-resources client {:subject (->user "super-user") +; :permission :view +; :resource/type :server +; :cursor nil +; :limit 1000})))) +; +; (time (count (:data (eacl/lookup-resources client {:subject (->user "super-user") +; :permission :view +; :resource/type :server +; :cursor nil +; :limit 100000000})))) +; +; (time (count (:data (eacl/lookup-resources client {:subject (->user "super-user") +; :permission :view +; :resource/type :server +; :cursor nil +; :limit 1000})))) +; +; (let [test-user (rand-user (d/db conn))] +; (let [{:as page1 +; p1-data :data +; p1-cursor :cursor} +; (eacl/lookup-resources client {:subject (->user test-user) +; :permission :view +; :resource/type :server +; :cursor nil +; :limit 600}) +; page1-count (count p1-data) +; +; {:as page2 +; p2-data :data +; p2-cursor :cursor} +; (eacl/lookup-resources client {:subject (->user test-user) +; :permission :view +; :resource/type :server +; :cursor p1-cursor +; :limit 400}) +; page2-count (count p2-data) +; +; {:as page3 +; p3-data :data +; p3-cursor :cursor} +; (eacl/lookup-resources client {:subject (->user test-user) +; :permission :view +; :resource/type :server +; :cursor p2-cursor +; :limit 100}) +; page3-count (count p3-data) +; +; total-count (+ page1-count page2-count page3-count) +; all-pages-data (concat p1-data p2-data p3-data) +; unique-count (count (distinct all-pages-data))] +; (assert (> total-count 700)) +; {:total/count total-count +; :count [page1-count page2-count page3-count] +; :cursors [p1-cursor p2-cursor p3-cursor] +; :data (concat p1-data p2-data p3-data) +; :unique-count unique-count})) +; +; (let [test-user (rand-user (d/db conn))] +; ; fetch two pages of data (we are not checking correctness here) +; (let [{:as page1 +; data :data +; p1-cursor :cursor} +; (eacl/lookup-resources client {:subject (->user test-user) +; :permission :view +; :resource/type :server +; :cursor nil +; :limit 600}) +; c1 (count data) +; +; {:as page2 +; data :data +; p2-cursor :cursor} +; (eacl/lookup-resources client {:subject (->user test-user) +; :permission :view +; :resource/type :server +; :cursor p1-cursor +; :limit 400}) +; c2 (count data)] +; [p1-cursor p2-cursor])) +; +; (eacl/count-resources client {:subject (->user "super-user") +; :permission :view +; :resource/type :server +; :cursor nil}) +; +; (crit/quick-bench +; (let [page (eacl/lookup-resources client {:subject (->user "super-user") +; :permission :view +; :resource/type :server +; :cursor nil +; :limit 1000000000})])) +; +; (crit/quick-bench +; (let [test-user (rand-user (d/db conn))] +; ; fetch two pages of data (we are not checking correctness here) +; (let [{:as page1 :keys [data cursor]} +; (eacl/lookup-resources client {:subject (->user test-user) +; :permission :view +; :resource/type :server +; :cursor nil +; :limit 600}) +; c1 (count data) +; +; {:as page2 :keys [data cursor]} +; (eacl/lookup-resources client {:subject (->user test-user) +; :permission :view +; :resource/type :server +; :cursor cursor +; :limit 400}) +; c2 (count data)] +; nil))) +; +; (let [test-server (rand-server (d/db conn))] +; (prn 'test-server test-server) +; (time (count (eacl/lookup-subjects client {:resource (->server test-server) +; :permission :view +; :subject/type :user})))) +; +; (time (count (eacl/read-relationships client {:resource/type :account}))) +; (time (count (eacl/read-relationships client {:resource/type :server}))) +; ()) +; +; ; Transact Test Data +; (let [num-accounts 100 +; num-users 10 +; num-servers 1000 +; account-uuids (repeatedly num-accounts d/squuid) +; account-txes (time (->> account-uuids +; (mapv (partial make-account-txes {:num-users num-users +; :num-servers num-servers})) +; (flatten))) +; tx-count (count account-txes)] +; ;(log/warn "Skipping txe.") +; (log/debug "Transacting " tx-count " things.") +; (tx! conn account-txes) +; +; (let [!counter (atom 0) +; !mistakes (atom 0) +; client (spiceomic/make-client conn {}) +; db (d/db conn) +; {:as setup :keys [accounts users servers]} (time (setup-benchmark db)) +; _ (do (log/debug "N accounts" (count accounts)) +; (log/debug "N users" (count users)) +; (log/debug "N servers" (count servers))) +; server->user-set (time (into {} +; (for [server-id servers] +; [server-id (set (server->user-ids db server-id))]))) +; server->users (time (into {} +; (for [server-id servers] +; [server-id (vec (server->user-ids db server-id))])))] +; ;(prn 'server->users server->users) +; (when false ; true ; false ; do +; (log/debug "Starting benchmark...") +; (crit/quick-bench +; (let [random-server (rand-nth servers) +; expected-userset (server->user-set random-server) +; expected-user-list (server->users random-server) +; ;_ (prn 'expected-user-list expected-user-list) +; random-user (if (and (>= (rand) 0.5) (seq expected-user-list)) ; some empty +; (rand-nth expected-user-list) +; (rand-nth users)) +; expected (contains? expected-userset random-user) +; _ (swap! !counter inc) +; actual (eacl/can? client (->user random-user) :view (->server random-server))] +; ;(log/debug expected random-user random-server) +; (when (not= expected actual) +; (swap! !mistakes inc)) +; [expected actual])) +; (prn 'counter @!counter 'mistakes @!mistakes))))) +; +;;(let [result-matrix (time (run-benchmark !counter client setup)) +;; checks (check-results server->user-set result-matrix) +;; matches (map (fn [[actual expected]] +;; (= actual expected)) checks) +;; disparities (frequencies matches)] +;; (log/debug 'disparities disparities) +;; (log/debug 'counter @!counter) +;; disparities)))) +; +;(comment +; ; ok so we have 100 accounts, 10 users per account, and 1000 servers per account +; ; th ameans we ahve 100 * 1000 = 100,000 servers. +; ; total users = 10 * 100 = 1,000 users +; ; users * servers = 100,000 * 1,000 = 100,000,000 M permission checks. +; +; (let [db (d/db conn) +; ; pull some relations +; users-cos (d/q '[:find ?user ?company +; :where +; [?user :user/username] +; [?rel :eacl/subject ?user] +; [?rel :eacl/relation :company/owner] +; [?rel :eacl/resource ?company]] +; db)] +; (prn (count users-cos) 'users-cos) +; (time +; (doall (frequencies (->> users-cos (pmap (fn [[user company]] +; (eacl/can? db user :company/view company)))))))) +; +; (let [subjects (d/q '[:find [?subject ...] +; :where +; [?subject :eacl/subject]] +; (d/db conn)) +; subject (rand-nth subjects)])) +;;(prn 'can? (eacl/can? (d/db conn) (:db/id subject) :company/view [:eacl/id (first cids)])))) +; +;(comment +; (d/q '[:find (count ?account) . +; :where +; [?account :eacl/type :account]] +; (d/db conn)) +; +; (d/q '[:find (count ?server) . +; :where +; [?server :eacl/type :server]] +; (d/db conn)) +; +; (d/q '[:find (count ?user) . +; :where +; [?user :eacl/type :user]] +; (d/db conn))) diff --git a/modules/eacl-datomic/test/eacl/datomic/config_test.clj b/modules/eacl-datomic/test/eacl/datomic/config_test.clj new file mode 100644 index 000000000..d19bfab61 --- /dev/null +++ b/modules/eacl-datomic/test/eacl/datomic/config_test.clj @@ -0,0 +1,54 @@ +(ns eacl.datomic.config-test + "As of 2025-06-28, EACL supports configurable ID attributes." + (:require [clojure.test :as t :refer [deftest testing is]] + [eacl.core :as eacl] + [datomic.api :as d] + [eacl.datomic.core] + [eacl.datomic.schema :as schema] + [eacl.datomic.fixtures :as fixtures :refer [->user ->server]] + [eacl.datomic.datomic-helpers :as helpers :refer [with-mem-conn]])) + +(deftest eacl-config-tests + (testing "" + (with-mem-conn [conn schema/v6-schema] + @(d/transact conn (concat fixtures/relations+permissions fixtures/entity-fixtures)) + @(d/transact conn (fixtures/relationship-fixtures (d/db conn))) + ;@(d/transact conn [{:db/ident :my/id + ; :db/doc "Your custom ID here, e.g. UUID in this case." + ; :db/valueType :db.type/uuid + ; :db/cardinality :db.cardinality/one + ; :db/unique :db.unique/identity}]) + ; Q: do we want lookups to fail if entity does not exist? + (testing "we can override EACL's object ID to Datomic ident resolution" + (let [client (eacl.datomic.core/make-client conn + { + ;:entity->object-id (fn [ent] (:)) + ;:object-id->ident (fn [obj-id] [:my/id obj-id])})] + :object-id->ident (fn [obj-id] [:db/ident obj-id])})] + + ; todo: also test read/write-relationships, and count-resources. + + (testing "lookup-resources throws for missing subject ident with some detail" + (is (thrown? Throwable (eacl/lookup-resources client + {:subject (->user :missing-ident) + :permission :view + :resource/type :server + :limit 1000 + :cursor nil})))) + + (testing "basic can? works when passing :db/ident" + (is (true? (eacl/can? client (->user :test/user1) :view (->server :test/server1)))) + (is (false? (eacl/can? client (->user :test/user2) :view (->server :test/server1)))) + (is (true? (eacl/can? client (->user :test/user2) :view (->server :test/server2))))) + + (is (= 2 (count (:data (eacl/lookup-resources client {:subject (->user :test/user1) + :permission :view + :resource/type :server}))))) + + (is (= 2 (:count (eacl/count-resources client {:subject (->user :test/user1) + :permission :view + :resource/type :server})))) + + (is (= 2 (count (:data (eacl/lookup-subjects client {:resource (->server :test/server1) + :permission :view + :subject/type :user})))))))))) diff --git a/modules/eacl-datomic/test/eacl/datomic/contract_test.clj b/modules/eacl-datomic/test/eacl/datomic/contract_test.clj new file mode 100644 index 000000000..822332ea1 --- /dev/null +++ b/modules/eacl-datomic/test/eacl/datomic/contract_test.clj @@ -0,0 +1,24 @@ +(ns eacl.datomic.contract-test + (:require [clojure.test :refer [deftest]] + [datomic.api :as d] + [eacl.contract-support :as contract] + [eacl.core :as eacl] + [eacl.datomic.core :as datomic] + [eacl.datomic.datomic-helpers :refer [with-mem-conn]] + [eacl.datomic.schema :as schema])) + +(defn- seed-objects! + [conn] + @(d/transact conn + (mapv (fn [{:keys [id]}] + {:db/id id + :eacl/id id}) + contract/smoke-objects))) + +(deftest datomic-contract-test + (with-mem-conn [conn schema/v6-schema] + (let [client (datomic/make-client conn {})] + (eacl/write-schema! client contract/smoke-schema) + (seed-objects! conn) + (eacl/create-relationships! client contract/smoke-relationships) + (contract/assert-seeded-contracts! client)))) diff --git a/modules/eacl-datomic/test/eacl/datomic/datomic_helpers.clj b/modules/eacl-datomic/test/eacl/datomic/datomic_helpers.clj new file mode 100644 index 000000000..4dfc18709 --- /dev/null +++ b/modules/eacl-datomic/test/eacl/datomic/datomic_helpers.clj @@ -0,0 +1,28 @@ +(ns eacl.datomic.datomic-helpers + (:require [datomic.api])) + +(defmacro with-mem-conn + "Like with-open for Datomic (for tests). + Not under ~/test because needed by other modules. + + 1. Creates unique in-memory Datomic. + 2. Transacts schema. + 3. Executes body with conn bound to sym. + 3. Deletes database after. + + Usage: + (with-mem-conn [conn some-schema] + @(d/transact conn tx-data) + (is (= 123 (d/q '[:find ...] (d/db conn)))))" + [[sym schema] & body] + `(let [random-uuid# (java.util.UUID/randomUUID) + datomic-uri# (str "datomic:mem://test-" (.toString random-uuid#)) + g# (datomic.api/create-database datomic-uri#)] ; can fail, but should not. + (assert (true? g#) (str "Failed to create in-memory Datomic:" datomic-uri#)) + (let [~sym (datomic.api/connect datomic-uri#)] + (try + @(datomic.api/transact ~sym ~schema) ; can fail. + (do ~@body) + (finally + (datomic.api/release ~sym) + (datomic.api/delete-database datomic-uri#)))))) \ No newline at end of file diff --git a/modules/eacl-datomic/test/eacl/datomic/fixtures.clj b/modules/eacl-datomic/test/eacl/datomic/fixtures.clj new file mode 100644 index 000000000..a3b95526d --- /dev/null +++ b/modules/eacl-datomic/test/eacl/datomic/fixtures.clj @@ -0,0 +1,380 @@ +(ns eacl.datomic.fixtures + (:require [datomic.api :as d] + [eacl.core :refer [spice-object]] + [eacl.datomic.impl :as impl :refer [Relation Relationship Permission]])) + +; These are helpers specific to CA (todo move out): +(def ->user (partial spice-object :user)) +(def ->group (partial spice-object :group)) ; new: to test multi-type support on Permission. +(def ->team (partial spice-object :team)) +(def ->server (partial spice-object :server)) +(def ->platform (partial spice-object :platform)) +(def ->account (partial spice-object :account)) +(def ->vpc (partial spice-object :vpc)) +(def ->network (partial spice-object :network)) +(def ->lease (partial spice-object :lease)) +(def ->nic (partial spice-object :network_interface)) +(def ->backup (partial spice-object :backup)) +(def ->backup-schedule (partial spice-object :backup_schedule)) +(def ->host (partial spice-object :host)) + +(def relations+permissions + [;; Schema + ; Platform for super_admin rights + (Relation :platform :super_admin :user) ; definition platform { relation super_admin: user } + + ; model: server -> nic -> lease -> network -> vpc. + (Relation :server :nic :network_interface) ; a server can have many NICs. definition server { relation nic: network_interface } + (Relation :network_interface :lease :lease) ; a NIC can have a lease (to an IP). definition network { relation lease: lease } + (Relation :lease :network :network) ; a lease has a network. definition lease { relation network: network } + (Relation :network :vpc :vpc) ; a network has a vpc. definition network { relation vpc: vpc } + + ; VPC Relations: + (Relation :vpc :account :account) ; definition vpc { relation account: account } + (Relation :vpc :shared_admin :user) ; vpc { relation shared_admin: user } + (Relation :vpc :shared_member :user) ; vpc { relation shared_member: user } + + ; VPC Permissions: + + ; vpc { permission admin = account->admin + shared_admin } + (Permission :vpc :admin {:arrow :account :permission :admin}) + (Permission :vpc :admin {:relation :shared_admin}) + + ; vpc { permission view = account->admin + shared_admin + shared_member } + (Permission :vpc :view {:arrow :account :permission :admin}) + (Permission :vpc :view {:relation :shared_admin}) + (Permission :vpc :view {:relation :shared_member}) + + ; vpc { permission rename = account->admin + shared_admin } + (Permission :vpc :rename {:arrow :account :permission :admin}) + (Permission :vpc :rename {:relation :shared_admin}) + + ; vpc { permission share = account->admin + shared_admin } + (Permission :vpc :share {:arrow :account :permission :admin}) + (Permission :vpc :share {:relation :shared_admin}) + + ; vpc { permission delete = account->admin + shared_admin } + (Permission :vpc :delete {:arrow :account :permission :admin}) + (Permission :vpc :delete {:relation :shared_admin}) + + ; vpc { permission create_server = account->admin + shared_admin } + (Permission :vpc :create_server {:arrow :account :permission :admin}) + (Permission :vpc :create_server {:relation :shared_admin}) + + ; vpc { permission restore_from_backup = account->admin + shared_admin } + (Permission :vpc :restore_from_backup {:arrow :account :permission :admin}) + (Permission :vpc :restore_from_backup {:relation :shared_admin}) + + (Permission :network_interface :view {:relation :lease}) ; direct + (Permission :network_interface :view {:arrow :lease :permission :view}) ; arrow + + (Permission :lease :view {:relation :network}) ; direct + (Permission :lease :view {:arrow :network :permission :view}) ; arrow + + (Permission :network :view {:relation :vpc}) ; direct + (Permission :network :view {:arrow :vpc :permission :view}) ; arrow + + ; definition server { permission view = + + ; Accounts: + (Relation :account :owner :user) ; Account has an owner (a user) + (Relation :account :owner :group) ; to demonstrate multiple subject types permission. + (Relation :account :platform :platform) + + ; definition account { permission admin = owner + platform->super_admin } + (Permission :account :admin {:relation :owner}) ; Owner of account gets admin on account (can be :user or :group) + (Permission :account :admin {:arrow :platform :relation :super_admin}) + + ; definition account { permission view = owner + platform->super_admin } + (Permission :account :view {:relation :owner}) + (Permission :account :view {:arrow :platform :relation :super_admin}) + + ; Special permission for test case: + ; definition account { permission view_via_arrow_relation = platform->super_admin } + (Permission :account :view_via_arrow_relation {:arrow :platform :relation :super_admin}) + + ; Teams: + (Relation :team :account :account) + (Relation :team :member :user) + + ;; Servers: + (Relation :server :account :account) + (Relation :server :shared_admin :user) + (Relation :server :shared_member :user) + (Relation :server :vpc :vpc) + + ; definition server { permission admin = account->admin + vpc->admin + shared_admin } + (Permission :server :admin {:arrow :account :permission :admin}) + (Permission :server :admin {:arrow :vpc :permission :admin}) + (Permission :server :admin {:relation :shared_admin}) + + ; definition server { permission view = admin + account + nic->view } + (Permission :server :view {:permission :admin}) + ;(Permission :server :view {:relation :account}) ; why do we need this? + ;(Permission :server :view {:arrow :account :permission :admin}) + (Permission :server :view {:arrow :nic :permission :view}) + ;(Permission :server :view {:relation :shared_admin}) + + (Permission :server :view {:relation :shared_member}) + (Permission :server :view {:relation :backup_creator}) + + (Permission :server :start {:arrow :account :permission :admin}) + (Permission :server :start {:relation :shared_admin}) + + ; definition server { permission edit = owner } ; admin? + (Permission :server :edit {:permission :admin}) + + ; definition server { permission delete = account->admin } + (Permission :server :delete {:arrow :account :permission :admin}) + + ; definition server { permission reboot = account->admin + shared_admin } + (Permission :server :reboot {:arrow :account :permission :admin}) + (Permission :server :reboot {:relation :shared_admin}) + + (Permission :server :view_server_via_arrow_relation {:arrow :account :permission :view_via_arrow_relation}) ; special test case. + + ; this is not supported yet, use :relation in meantime: + (Permission :server :share {:permission :admin}) + ;(Permission :server :share {:arrow :account :permission :admin}) + ;(Permission :server :share {:arrow :vpc :permission :admin}) + ;(Permission :server :share {:relation :shared_admin}) + + (Permission :server :via_self_admin {:arrow :self :permission :admin}) ; to test :self->permission. + + ; definition server { permission delete = admin } + (Permission :server :delete {:permission :admin}) + + ; Server Backup & Restore + ; server { permission restore_over = account->admin + shared_admin } + (Permission :server :restore_over {:permission :admin}) + + ;(Permission :server :restore_over {:arrow :account :permission :admin}) + ;(Permission :server :restore_over {:relation :shared_admin}) + + ; server { permission take_backup = account->admin + shared_admin } + + (Permission :server :take_backup {:permission :admin}) + + ;(Permission :server :take_backup {:arrow :account :permission :admin}) + ;(Permission :server :take_backup {:relation :shared_admin}) + + ; Server Backup Schedule Creation + ; Note that deletion of backup_schedule is handled by own resource_type, :backup_schedule. + + ; server { permission create_backup_schedule = account->admin + shared_admin } + + (Permission :server :create_backup_schedule {:permission :admin}) + + ;(Permission :server :create_backup_schedule {:arrow :account :permission :admin}) + ;(Permission :server :create_backup_schedule {:relation :shared_admin}) + + ; Backup Schedules + (Relation :backup_schedule :server :server) + (Relation :backup_schedule :shared_backup_viewer :user) + (Relation :backup_schedule :viewer :user) + + ; backup_schedule { permission view = server->admin + viewer} + (Permission :backup_schedule :view {:arrow :server :permission :admin}) + (Permission :backup_schedule :view {:relation :viewer}) ; should not need :self. + + ; backup_schedule { permission share = server->admin } + ; note: share permission reused for unshare. + (Permission :backup_schedule :share {:arrow :server :permission :admin}) + + ; backup_schedule { permission delete = server->admin } + (Permission :backup_schedule :delete {:arrow :server :permission :admin}) + + ;; Backup Relations + (Relation :backup :server :server) + (Relation :backup :account :account) + (Relation :backup :vpc :vpc) + (Relation :backup :schedule :backup_schedule) + + ;; Backup Permissions + ; backup { permission view = account->admin + vpc->admin + server->admin } + (Permission :backup :view {:arrow :account :permission :admin}) + (Permission :backup :view {:arrow :vpc :permission :admin}) + (Permission :backup :view {:arrow :server :permission :admin}) + ;(Permission :backup :view {:arrow :schedule :relation :viewer}) ; bug: should not need this. + (Permission :backup :view {:arrow :schedule :permission :view}) ; :viewers can also see backups created by this schedule. + + ; backup { permission delete = account->admin + vpc->admin + server->admin } + (Permission :backup :delete {:arrow :account :permission :admin}) + (Permission :backup :delete {:arrow :vpc :permission :admin}) + (Permission :backup :delete {:arrow :server :permission :admin})]) + +(def entity-fixtures + [; Global Platform for Super Admins: + {:db/id "platform" + :db/ident :test/platform + :eacl/id "platform"} + + ; Users: + {:db/id "user-1" + :db/ident :test/user1 + :eacl/id "user-1"} + + {:db/id "user-2" + :db/ident :test/user2 + :eacl/id "user-2"} + + ; Group 1 (to test multiple subject types for account :owner relation): + {:db/id "group-1" + :db/ident :test/group1 + :eacl/id "group-1"} + + ; Super User can do all the things: + {:db/id "super-user" + :db/ident :user/super-user + :eacl/id "super-user"} + + ;; Servers + ;; ...Account 1 Servers: + {:db/id "account1-server1" + :db/ident :test/server1 + :eacl/id "account1-server1"} + + {:db/id "account1-server2" + :eacl/id "account1-server2"} + + ; ...Account 2 Servers: + {:db/id "account2-server1" + :db/ident :test/server2 + :eacl/id "account2-server1"} + + ; Order matters here: accounts are intentionally after servers + ; to force eids to be larger than servers above. + ; Accounts + {:db/id "account-1" + :db/ident :test/account1 + :eacl/id "account-1"} + + {:db/id "account-2" + :db/ident :test/account2 + :eacl/id "account-2"} + + + ; VPC + {:db/id "vpc-1" + :db/ident :test/vpc1 + :eacl/id "vpc-1"} + + {:db/id "vpc-2" + :db/ident :test/vpc2 + :eacl/id "vpc-2"} + + {:db/id "account1-vpc2" + :db/ident :test/account1-vpc2 + :eacl/id "account1-vpc2"} + + {:db/id "account1-vpc3" + :db/ident :test/account1-vpc3 + :eacl/id "account1-vpc3"} + + ;; Networks, NICs & Leases + + {:db/id "network-1" + :db/ident :test/network1 + :eacl/id "network-1"} + + {:db/id "nic-1" + :db/ident :test/nic1 + :eacl/id "nic-1"} + + {:db/id "lease-1" + :db/ident :test/lease1 + :eacl/id "lease-1"} + + ; Team + {:db/id "team-1" + :db/ident :test/team + :eacl/id "team-1"} + + {:db/id "team-2" + :db/ident :test/team2 + :eacl/id "team-2"} + + {:db/id "backup-schedule-1" + :db/ident :test/backup-schedule1 + :eacl/id "backup-schedule-1"} + + ; Backup + {:db/id "backup-1" + :db/ident :test/backup1 + :eacl/id "backup-1"} + + {:db/id "backup-2" + :db/ident :test/backup2 + :eacl/id "backup-2"}]) + +(def relationship-fixture-data + [; we need to specify types for indices, but id can be tempid here. + (Relationship (->user "user-1") :member (->team "team-1")) ; User 1 is on Team 1 + (Relationship (->user "user-1") :owner (->account "account-1")) + + (Relationship (->user "super-user") :super_admin (->platform "platform")) + + (Relationship (->user "user-2") :owner (->account "account-2")) + + (Relationship (->group "group-1") :owner (->account "account-1")) ; new. + + (Relationship (->platform "platform") :platform (->account "account-1")) + (Relationship (->platform "platform") :platform (->account "account-2")) + + (Relationship (->account "account-1") :account (->vpc "vpc-1")) + (Relationship (->account "account-1") :account (->vpc "account1-vpc2")) + (Relationship (->account "account-1") :account (->vpc "account1-vpc3")) + + (Relationship (->account "account-2") :account (->vpc "vpc-2")) + + ; server -> nic -> lease -> network -> vpc + (Relationship (->vpc "vpc-1") :vpc (->network "network-1")) + (Relationship (->network "network-1") :network (->lease "lease-1")) + (Relationship (->lease "lease-1") :lease (->nic "nic-1")) + (Relationship (->nic "nic-1") :nic (->server "account1-server1")) + + ; Teams belongs to accounts + (Relationship (->account "account-1") :account (->team "team-1")) + (Relationship (->account "account-2") :account (->team "team-2")) + + (Relationship (->account "account-1") :account (->server "account1-server1")) ; hmm let's check schema plz. + (Relationship (->account "account-1") :account (->server "account1-server2")) + + (Relationship (->account "account-2") :account (->server "account2-server1")) + + ; this should warn: + ;(Relationship (->account "account-1") :account (->backup-schedule "backup-schedule-1")) + (Relationship (->server "account1-server1") :server (->backup-schedule "backup-schedule-1")) + + (Relationship (->backup-schedule "backup-schedule-1") :schedule (->backup "backup-1")) + (Relationship (->account "account-1") :account (->backup "backup-1")) + (Relationship (->server "account1-server1") :server (->backup "backup-1"))]) + +(defn relationship-fixtures + [db] + (mapcat #(impl/tx-relationship db %) relationship-fixture-data)) + +(defn base-fixtures + [db] + (concat + relations+permissions + entity-fixtures + (relationship-fixtures db))) + +(defn txes-additional-account3+server + "To test accounts & servers with higher eids." + [db] + (concat + [{:db/id "account3-server3.1" + :db/ident :test/account3-server1 + :eacl/id "account3-server3.1"} + + {:db/id "account-3" + :db/ident :test/account3 + :eacl/id "account-3"}] + (mapcat #(impl/tx-relationship db %) + [(Relationship (->account "account-3") :account (->server "account3-server3.1")) + (Relationship (->user :test/user1) :owner (->account "account-3"))]))) + +;; (For Later) Team Membership: +;(Relationship "user-2" :team/member "team-2") diff --git a/modules/eacl-datomic/test/eacl/datomic/impl/indexed_test.clj b/modules/eacl-datomic/test/eacl/datomic/impl/indexed_test.clj new file mode 100644 index 000000000..44b95de2d --- /dev/null +++ b/modules/eacl-datomic/test/eacl/datomic/impl/indexed_test.clj @@ -0,0 +1,1140 @@ +(ns eacl.datomic.impl.indexed-test + (:require [clojure.test :as t :refer [deftest testing is]] + [clojure.tools.logging :as log] + [datomic.api :as d] + [eacl.datomic.datomic-helpers :refer [with-mem-conn]] + [eacl.datomic.fixtures :as fixtures :refer [->user ->group ->server ->account ->vpc ->nic ->network ->lease ->backup ->backup-schedule]] + [eacl.core :as eacl :refer [spice-object]] + [eacl.datomic.schema :as schema] + [eacl.lazy-merge-sort :refer [lazy-merge-dedupe-sort]] + [eacl.datomic.impl :as impl + :refer [Relation Relationship Permission + can? + read-relationships]] + ;[eacl.datomic.impl.datalog :as impl.datalog :refer [lookup-subjects]] + [eacl.datomic.impl.indexed :as impl.indexed :refer [count-resources lookup-resources lookup-subjects]])) + +; Test grouping & cleanup is in progress. + +(def ^:dynamic *conn* nil) + +(deftest lazy-merge-sort-tests + (is (= [1 2 3 4 5 6 7 8 9 10 11] + (let [seq1 [1 3 5 7 9] + seq2 [2 3 6 8 9 10] + seq3 [1 4 5 6 11]] + (take 20 (lazy-merge-dedupe-sort [seq1 seq2 seq3])))))) + +;; Load schema from SpiceDB DSL file +(def fixtures-schema-string + (slurp "test/eacl/fixtures.schema")) + +(defn eacl-schema-fixture [f] + (with-mem-conn [conn schema/v6-schema] + ;; Use write-schema! with SpiceDB DSL instead of direct Relation/Permission fixtures + (schema/write-schema! conn fixtures-schema-string) + ;; Transact entity fixtures and relationship fixtures together (tempids reference each other) + (is @(d/transact conn (concat fixtures/entity-fixtures + (fixtures/relationship-fixtures (d/db conn))))) + (is @(d/transact conn (fixtures/txes-additional-account3+server (d/db conn)))) + (binding [*conn* conn] + (doall (f))))) + +(t/use-fixtures :each eacl-schema-fixture) + +;; Test Helpers + +(comment + + (d/delete-database in-mem-uri) + + (do + (def in-mem-uri "datomic:mem://stateful-test") + + (let [created? (d/create-database in-mem-uri) + conn (d/connect in-mem-uri)] + (prn 'created? created?) + + (when created? + (prn 'transacting 'schema) + @(d/transact conn schema/v6-schema) + @(d/transact conn (fixtures/base-fixtures (d/db conn)))) + + (->> (lookup-resources (d/db conn) + {:subject (->vpc :test/vpc1) + :permission :view + :resource/type :server + :limit 1000 + :cursor nil}) + (:data))))) + +(defn paginated-data->spice + "To make tests pass after we moved to eids in internals." + [db data] + (->> data + (map (fn [{:as obj :keys [type id]}] + (let [ent (d/entity db id)] + (spice-object type (:eacl/id ent))))))) + +(defn paginated->spice + "To make tests pass after we moved to eids in internals." + [db {:as page :keys [data cursor]}] + (paginated-data->spice db data)) + +(defn paginated->spice-set + "To make tests pass after we moved to eids in internals." + [db {:as page :keys [data cursor]}] + (set (paginated->spice db page))) + +(deftest permission-helper-tests + (testing "Permission helper with new unified API" + (is (= #:eacl.permission{:eacl/id "eacl:permission::server::admin::self::relation::owner" + :resource-type :server + :permission-name :admin + :source-relation-name :self + :target-type :relation + :target-name :owner} + (Permission :server :admin {:relation :owner}))) + (testing "arrow permission to permission" + (is (= #:eacl.permission{:eacl/id "eacl:permission::server::admin::account::permission::admin" + :resource-type :server + :permission-name :admin + :source-relation-name :account + :target-type :permission + :target-name :admin} + (Permission :server :admin {:arrow :account :permission :admin})))) + (testing "arrow permission to relation" + (is (= #:eacl.permission{:eacl/id "eacl:permission::server::view::account::relation::owner" + :resource-type :server + :permission-name :view + :source-relation-name :account + :target-type :relation + :target-name :owner} + (Permission :server :view {:arrow :account :relation :owner})))))) + +(deftest check-permission-tests + (let [db (d/db *conn*) + super-user-eid (d/entid db :user/super-user)] + + (testing "we can count resources (materializes full index)" + (is (= 3 (:count (count-resources db {:subject (->user super-user-eid) + :permission :view + :resource/type :server + :limit 1000 + :cursor nil}))))) + + (testing ":test/user1 can :view, :reboot or :share server1" + (is (can? db (->user :test/user1) :view (->server :test/server1))) + (is (can? db (->user :test/user1) :share (->server :test/server1))) + (is (can? db (->user :test/user1) :reboot (->server :test/server1)))) + + (testing "but :test/user2 can't :view, :reboot or :share server1" + (is (not (can? db (->user :test/user2) :view (->server :test/server1)))) + (is (not (can? db (->user :test/user2) :share (->server :test/server1)))) + (is (not (can? db (->user :test/user2) :reboot (->server :test/server1))))) + + (testing "can? supports :db/id and idents" + (let [user1-eid (d/entid db :test/user1)] + (is (can? db (->user user1-eid) :view (->server :test/server1)))) + + (is (can? db (->user [:eacl/id "user-1"]) :view (->server [:eacl/id "account1-server1"]))) + (is (can? db (->user :test/user1) :view (->server [:eacl/id "account1-server1"])))) + + (testing "can? supports passing :db/id directly" + (let [subject-eid (d/entid db :test/user1) + resource-eid (d/entid db :test/server1)] + (is (can? db (->user subject-eid) :view (->server resource-eid))))) + + (testing "...but :test/user2 can't." + (is (not (can? db (->user :test/user2) :view (->server :test/server1)))) + (is (not (can? db (->user :test/user2) :reboot (->server :test/server1))))) + + (testing "user1 can share a server via a direct :permission on admin" + (is (can? db (->user :test/user1) :share (->server :test/server1))) + (is (not (can? db (->user :test/user2) :share (->server :test/server1))))) + + (testing ":test/user1 is admin of :test/vpc1 because they own account" + (is (can? db (->user :test/user1) :admin (->vpc :test/vpc1)))) + + (testing "and so is super-user because he is super_admin of platform" + (is (can? db (->user :user/super-user) :admin (->vpc :test/vpc1)))) + + (testing "but :test/user2 is not" + (is (not (can? db (->user :test/user2) :admin (->vpc :test/vpc1))))) + + (testing "Sanity check that relations don't affect wrong resources" + (is (not (can? db (->user :test/user2) :view (->account :test/account1))))) + + (testing "User 2 can view server 2" + (is (can? db (->user :test/user2) :view (->server :test/server2)))) + + (testing "Super User can view all servers" + (is (can? db (->user :user/super-user) :view (->server :test/server1))) + (is (can? db (->user :user/super-user) :view (->server :test/server2)))) + + (testing "User 2 can delete server2 because they have server.owner relation" + (is (can? db (->user :test/user2) :delete (->server :test/server2))) + (testing "...but not :test/user1" + (is (not (can? db (->user :test/user1) :delete (->server :test/server2)))))))) + +(deftest complex-relation-tests + (testing "does EACL support reverse lookups?" + (let [db (d/db *conn*)] + (is (can? db (->lease :test/lease1) :view (->server :test/server1))) + (is (can? db (->network :test/network1) :view (->server :test/server1))) + (is (can? db (->vpc :test/vpc1) :view (->server :test/server1))) ; why does htis work, but below does not? + + (is (can? db (->user :test/user1) :via_self_admin (->server :test/server1))) + (is (not (can? db (->user :test/user2) :via_self_admin (->server :test/server1)))) + + (is (can? db (->user :test/user1) :view (->backup :test/backup1))) + (is (not (can? db (->user :test/user2) :view (->backup :test/backup1)))) + + (testing ":test/user1 can :view backup-schedule-1, but not :test/user2" + (is (can? db (->user :test/user1) :view (->backup-schedule :test/backup-schedule1))) + (is (not (can? db (->user :test/user2) :view (->backup-schedule :test/backup-schedule1))))) + + (testing "Adding :test/user2 as a :viewer of a backup schedule, lets them view related backups:" + (let [rx (d/with db + (impl/tx-relationship db + (Relationship (->user :test/user2) :viewer (->backup-schedule :test/backup-schedule1))))] + (is (can? (:db-after rx) (->user :test/user2) :view (->backup-schedule :test/backup-schedule1))) + (is (can? (:db-after rx) (->user :test/user2) :view (->backup :test/backup1))))) + + (is (not (can? db (->vpc :test/vpc2) :view (->server :test/server1)))) + + (let [vpc-eid (d/entid db :test/vpc1)] + (is (= [(->server "account1-server1")] + (->> (lookup-resources db + {:subject (->vpc vpc-eid) + :permission :view + :resource/type :server + :limit 1000 + :cursor nil}) + (paginated->spice db)))))))) + +(deftest read-relationships-tests + (let [db (d/db *conn*)] + (testing "we can find a relationship using internals" + (is (= {:subject-type :user + :subject-eid (d/entid db :test/user1) + :relation :owner + :resource-type :account + :resource-eid (d/entid db :test/account1)} + (let [rel (impl/find-one-relationship-id db {:subject (->user :test/user1) + :relation :owner + :resource (->account :test/account1)})] + {:subject-type (:subject-type rel) + :subject-eid (:subject-eid rel) + :relation (:relation rel) + :resource-type (:resource-type rel) + :resource-eid (:resource-eid rel)})))) + + (testing "find-one-relationship-by-id returns nil for missing subject or resource" + (is (nil? (impl/find-one-relationship-id db {:subject (->user "missing-user") + :relation :owner + :resource (->account "account-1")})))) + + (testing "read-relationships filters" + ;(is (= [] (read-relationships db {}))) + ; need better tests here. + (is (= #{:server} (set (map (comp :type :resource) (read-relationships db {:resource/type :server}))))) + (is (= #{:owner} (set (map :relation (read-relationships db {:resource/relation :owner}))))) + (is (= #{:account} (set (map :relation (read-relationships db {:resource/type :server + :resource/relation :account})))))))) + +(deftest lookup-subjects-tests + (let [db (d/db *conn*)] + (testing "We can enumerate subjects that can access a resource." + ; Bug: currently returns the subject itself which needs a fix. + (is (= #{(->user "user-1") + (->user "super-user")} + (->> (lookup-subjects db {:resource (->server (d/entid db :test/server1)) + :permission :view + :subject/type :user}) + (paginated->spice-set db)))) + + (is (= #{(->group "group-1")} + (->> (lookup-subjects db {:resource (->server (d/entid db :test/server1)) + :permission :view + :subject/type :group}) + (paginated->spice-set db)))) + + (testing ":test/user2 is only subject who can delete :test/server2" + (is (= #{(->user "user-2") + (->user "super-user")} + ; todo pagination + cursor. this is outdated. + (->> (lookup-subjects db {:resource (->server (d/entid db [:eacl/id "account2-server1"])) + :permission :delete + :subject/type :user}) + (paginated->spice-set db)))))))) + +(deftest eacl3-tests + + (let [db (d/db *conn*) + super-user-eid (d/entid db :user/super-user) + user1-eid (d/entid db :test/user1) + user2-eid (d/entid db :test/user2)] + + (testing "lookup-resources: super-user can view all servers" + ; note: the return order of `lookup-resources` depends on the tuple index, or any sort operation. + ; currently we sort, which is super slow. this needs to revert to the tuple-index order. + (let [{:as page1 + page1-data :data + page1-cursor :cursor} (lookup-resources db {:subject (->user super-user-eid) + :permission :view + :resource/type :server + :limit 1000 + :cursor nil}) + resources (paginated->spice db page1)] + (is (= [(spice-object :server "account1-server1") + (spice-object :server "account1-server2") + (spice-object :server "account2-server1")] + resources)) + (testing "cursor should be the last resource" + (is page1-cursor) + (let [last-resource-ent (d/entity db (:e page1-cursor)) + last-resource-internal (spice-object :server (:eacl/id last-resource-ent))] + (is (= (spice-object :server "account2-server1") last-resource-internal)))))) + + (testing "view_via_arrow_relation works" + (is (= #{(spice-object :account "account-1") + (spice-object :account "account-2")} + (->> (lookup-resources db {:subject (->user super-user-eid) + :permission :view_via_arrow_relation + :resource/type :account + :limit 1000 + :cursor nil}) + (paginated->spice db) + (set)))) + + (testing "...and server { permission view_via_arrow_relation = account->view_via_arrow_relation } works") + (is (= #{(spice-object :server "account1-server1") + (spice-object :server "account1-server2") + (spice-object :server "account2-server1")} + (->> (lookup-resources db {:subject (->user super-user-eid) + :permission :view_server_via_arrow_relation + :resource/type :server + :limit 1000 + :cursor nil}) + (paginated->spice db) + (set))))) + + (testing "We can enumerate resources with lookup-resources" + (is (= #{(spice-object :server "account1-server1") + (spice-object :server "account1-server2") + (spice-object :server "account3-server3.1")} + (->> (lookup-resources db {:subject (->user user1-eid) + :permission :view + :resource/type :server}) + (:data) + (map (fn [{:as obj :keys [type id]}] (spice-object type (:eacl/id (d/entity db id))))) + (set)))) + + (testing "count-resources returns 3 as above" + (is (= 3 (:count (count-resources db {:subject (->user user1-eid) + :permission :view + :resource/type :server}))))) + + (testing "same for :reboot permission" + (is (= [(->server "account1-server1") + (->server "account1-server2") + (->server "account3-server3.1")] + ; todo cursor + (->> (lookup-resources db {:subject (->user user1-eid) + :permission :reboot + :resource/type :server}) + (paginated->spice db))))) + + (testing "we can enumerate :account objects user1 can :view" + (is (= #{(->account "account-1") + (->account "account-3")} + (->> (lookup-resources db {:subject (->user user1-eid) + :permission :view + :resource/type :account}) + (paginated->spice db) + (set)))) + + (testing "count matches lookup" + (is (= 2 (:count (count-resources db {:subject (->user user1-eid) + :permission :view + :resource/type :account})))))) + + (is (= #{(->server "account2-server1")} + (->> (lookup-resources db + {:subject (->user user2-eid) + :permission :view + :resource/type :server}) + (paginated->spice db) + (set))))) + + (testing "Make user-1 a shared_admin of server-2" + (is @(d/transact *conn* + (impl/tx-relationship (d/db *conn*) + (Relationship (->user :test/user1) :shared_admin (->server :test/server2)))))) ; this shouldn't be working. no schema for it. + + (let [db (d/db *conn*)] + (testing "As a :shared_admin, :test/user1 can also :server/delete server 2" + (is (can? db (->user :test/user1) :delete (->server :test/server2))) + + (is (= #{(spice-object :server "account1-server1") + (spice-object :server "account1-server2") + (spice-object :server "account2-server1") + (spice-object :server "account3-server3.1")} + (->> (lookup-resources db {:subject (->user user1-eid) + :permission :view + :resource/type :server + :cursor nil}) + (paginated->spice-set db)))) + + (is (= #{(->user "super-user") + (->user "user-1") + (->user "user-2")} + (->> (lookup-subjects db {:resource (->server (d/entid db [:eacl/id "account2-server1"])) ; todo fix + :permission :delete + :subject/type :user}) + (paginated->spice-set db)))))) + + (testing "Now let's delete all :server/owner Relationships for :test/user2" + (let [db-for-delete (d/db *conn*) + rels (impl/read-relationships db-for-delete {:subject/id :test/user2 + :resource/relation :owner}) + txes (mapcat #(impl/tx-update-relationship db-for-delete + {:operation :delete + :relationship %}) + rels)] + (is @(d/transact *conn* txes)))) + + (testing "Now only user-1 can :view all 3 servers, including those in account2." + (let [db' (d/db *conn*)] + (is (= [(spice-object :user "user-1") + (spice-object :user "super-user")] + (->> (lookup-subjects db' {:resource (->server (d/entid db' [:eacl/id "account2-server1"])) + :permission :view + :subject/type :user}) + (paginated->spice db')))) + + (is (can? db' (->user (d/entid db' [:eacl/id "user-1"])) :view (->server [:eacl/id "account2-server1"]))) + (is (can? db' (->user (d/entid db' [:eacl/id "super-user"])) :view (->server [:eacl/id "account2-server1"]))) + (is (not (can? db' (->user (d/entid db' [:eacl/id "user2"])) :view (->server [:eacl/id "account2-server1"])))) + + (testing ":test/user2 cannot access any servers" ; is this correct? + (is (= #{} (->> (lookup-resources db' {:resource/type :server + :permission :view + :subject (->user [:eacl/id "user-2"])}) + (:data) + (set)))) + (testing "count-resources also zero" + (is (zero? (:count (count-resources db' {:resource/type :server + :permission :view + :subject (->user [:eacl/id "user-2"])})))))) + + (is (false? (can? db' (->user :test/user2) :delete (->server :test/server2)))) + + (testing ":test/user1 permissions remain unchanged" + (is (= #{(spice-object :server "account1-server1") + (spice-object :server "account1-server2") + (spice-object :server "account2-server1") + (spice-object :server "account3-server3.1")} + (->> (lookup-resources db' {:resource/type :server + :permission :reboot + :subject (->user user1-eid)}) + (paginated->spice-set db)))) + + (testing "super-user can still view all servers" + (is (= #{(spice-object :server "account1-server1") + (spice-object :server "account1-server2") + (spice-object :server "account2-server1")} + (->> (lookup-resources db' {:resource/type :server + :permission :reboot + :subject (->user super-user-eid)}) + (paginated->spice-set db))))) + + (is (= #{(spice-object :account "account-1") + (spice-object :account "account-3")} + (->> (lookup-resources db' {:resource/type :account + :permission :view + :subject (->user user1-eid)}) + (paginated->spice-set db))))))))) + +(deftest lookup-resources-tests + (let [db (d/db *conn*) + super-user-eid (d/entid db :user/super-user)] + + (testing "ensure account eids are larger than server to test cursor-pagination" + (let [account1 (d/entity db :test/account1) + server1 (d/entity db :test/server1)] + (is (> (:db/id account1) (:db/id server1))))) + + ;(testing "what happens when find-relation-def is called with source-relation-name `:self`?" + ; ; what do we expect here? + ; (is (nil? (impl.indexed/find-relation-def db :server :self)))) + + (testing "lookup of :view against :vpc works" + (is (= #{(->vpc "vpc-1") + (->vpc "account1-vpc2") + (->vpc "account1-vpc3")} (->> (lookup-resources db {:subject (->user :test/user1) + :permission :view + :resource/type :vpc}) + (paginated->spice-set db))))) + + (testing "`permission via_self_admin = admin` should work, but currently throws" + (is (->> (lookup-resources db {:subject (->user :test/user1) + :permission :via_self_admin + :resource/type :server})))) + + (testing "pagination: limit & offset are handled correctly for arrow permissions" + (testing "add a 3rd server. make super-user a direct shared_admin of server1 and server 3 to try and trip up pagination" + (is @(d/transact *conn* [{:db/id "server3" + :db/ident :test/server3 + :eacl/id "server-3"} + (first (impl/tx-relationship (d/db *conn*) + (Relationship (->user :user/super-user) :shared_admin (->server :test/server1)))) + (second (impl/tx-relationship (d/db *conn*) + (Relationship (->user :user/super-user) :shared_admin (->server :test/server1)))) + ; We can use tempids in Relationship because tuple tx-data keeps the tempid. + (first (impl/tx-relationship (d/db *conn*) + (Relationship (->user :user/super-user) :shared_admin (->server "server3")))) + (second (impl/tx-relationship (d/db *conn*) + (Relationship (->user :user/super-user) :shared_admin (->server "server3"))))]))) + + (let [db' (d/db *conn*)] + (testing "ensure user1 can only see servers from account1, so excludes server-3" + (is (= [(spice-object :server "account1-server1") + (spice-object :server "account1-server2") + (spice-object :server "account3-server3.1")] + (->> (lookup-resources db' {:subject (->user :test/user1) + :permission :view + :resource/type :server + :cursor nil}) + (paginated->spice db'))))) + + (testing "enumerate super-user servers with limit: 10 & nil cursor should return all 4 servers" + (is (= [(spice-object :server "account1-server1") + (spice-object :server "account1-server2") + (spice-object :server "account2-server1") + (spice-object :server "server-3")] + (->> (lookup-resources db' {:limit 10 + :cursor nil ; no cursor should return all 4 servers + :resource/type :server + :permission :view + :subject (->user super-user-eid)}) + (paginated->spice db')))) + + (testing "count-resources matches above" + (is (= 4 (:count (count-resources db' {:resource/type :server + :permission :view + :subject (->user super-user-eid)})))))) + (testing "limit: 10 with cursor set to 1st result should exclude the first result" + ; test failing because return order is oriented towards how it's stored in index + (is (= [(spice-object :server "account1-server2") ; (spice-object :server "account1-server1") is excludced. + (spice-object :server "account2-server1") + (spice-object :server "server-3")] + ; cursor seems weird here. shouldn't it be exclusive? + (->> (lookup-resources db' {:limit 10 + :cursor {:resource {:type :account + :id (d/entid db' [:eacl/id "account1-server1"])}} + :resource/type :server + :permission :view + :subject (->user super-user-eid)}) + (paginated->spice db'))))) + + ; Note that return order of Spice resources is not defined, because we do not sort during lookup. + ; We assume order will be: [server-1, server-3, server-2]. + (testing "limit 1 with cursor set to 2nd result should skip first two and return only 3rd result" + (is (= [(spice-object :server "account2-server1")] + ;(spice-object :server "server-3")] excluded because of limit. + (->> (lookup-resources db' {:cursor {:resource {:type :server + :id (d/entid db' [:eacl/id "account1-server2"])}} + :limit 1 + :resource/type :server + :permission :view + :subject (->user super-user-eid)}) + (paginated->spice db))))) + + (testing "limit 1, 3rd cursor offset should return 2nd result, server-3" + (is (= [(spice-object :server "server-3")] + (->> (lookup-resources db' {:cursor {:resource {:type :server + :id (d/entid db' [:eacl/id "account2-server1"])}} + :limit 1 + :resource/type :server + :permission :view + :subject (->user super-user-eid)}) + (paginated->spice db'))))) + + (testing "limit: 10, cursor at 3rd result only the 4th result" + (is (= [(spice-object :server "server-3")] + (->> (lookup-resources db' {:cursor {:resource {:type :server + :id (d/entid db' [:eacl/id "account2-server1"])}} + :limit 10 + :resource/type :server + :permission :view + :subject (->user super-user-eid)}) + (paginated->spice db'))))) + + (testing "offset: last cursor, limit: 10 should be empty" + (is (empty? (->> (lookup-resources db' {:limit 10 + :cursor {:resource {:type :server + :id (d/entid db' [:eacl/id "server-3"])}} + :resource/type :server + :permission :view + :subject (->user super-user-eid)}) + (paginated->spice db')))))) + + (let [db' (d/db *conn*)] + (testing "ask for 5 results (there are only 4), and ensure page1 & page2 are subsequences with matching cursor" + (let [both-pages (lookup-resources db' {:limit 5 + :cursor nil ; :cursor nil = first page. + :resource/type :server + :permission :view + :subject (->user super-user-eid)}) + + both-pages-resolved (paginated-data->spice db' (:data both-pages)) + [page1-expected + page2-expected + page3-expected] (partition-all 2 both-pages-resolved) + + {:as page1 + page1-data :data + page1-cursor :cursor} (lookup-resources db' {:limit 2 + :cursor nil ; no cursor should the first page. + :resource/type :server + :permission :view + :subject (->user super-user-eid)}) + ;_ (prn 'page1 'cursor (:cursor page1)) + {:as page2 + page2-data :data + page2-cursor :cursor} (lookup-resources db' {:limit 2 + :cursor (:cursor page1) + :resource/type :server + :permission :view + :subject (->user super-user-eid)}) + {:as page3-empty + page3-data :data + page3-cursor :cursor} (->> (lookup-resources db' {:limit 2 + :cursor (:cursor page2) + :resource/type :server + :permission :view + :subject (->user super-user-eid)}))] + + ;_ (prn 'page2 'cursor (:cursor page2))] + + (testing "page1 cursor points to next page" + (is page1-cursor) + (is (:e page1-cursor))) + + (testing "page2 cursor points to next page" + (is page2-cursor) + (is (:e page2-cursor))) + + (testing "page3 cursor matches page 2 because we exhausted results on page 2" + ; TODO: figure out what this should return. The previous cursor? + ; we probably need a flag for empty, but empty :data implies that. + (is (= page2-cursor page3-cursor))) + + (testing "limit 5 should include all 4 results, in sorted order" ; (depends on tuple index or costly sort) + (is (= [(spice-object :server "account1-server1") + (spice-object :server "account1-server2") + (spice-object :server "account2-server1") + (spice-object :server "server-3")] + (paginated-data->spice db' (:data both-pages))))) + + (testing "page1 with 1-2 of 4 should match the first 2 results" + (is (= page1-expected (paginated-data->spice db' page1-data)))) + + (testing "page2 with 3-4 of 4 should match the second two results" + (is (= page2-expected (paginated-data->spice db' page2-data)))) + + (testing "page3 with 5-6 of 4 should be empty (results exhausted)" + (is (nil? page3-expected)) + (is (empty? (paginated-data->spice db' page3-data)))) + + (testing "repeating page2 query with limit: 1 should return only the first result on that page" + (is (= (take 1 page2-expected) + (->> (lookup-resources db' {:limit 1 + :cursor page1-cursor + :resource/type :server + :permission :view + :subject (->user super-user-eid)}) + (paginated->spice db'))))) + + (testing "repeat page2 query with limit: 10 should return remainder" + (is (= (drop 2 both-pages-resolved) + (->> (lookup-resources db' {:limit 10 + :cursor page1-cursor + :resource/type :server + :permission :view + :subject (->user super-user-eid)}) + (paginated->spice db'))))) + + (testing "lookup-resources returns cursor input when looking beyond any values" + (let [page3-empty (lookup-resources db' {:limit 100 + :cursor page2-cursor + :resource/type :server + :permission :view + :subject (->user super-user-eid)})] + (is (empty? (:data page3-empty))) + (is (= page2-cursor (:cursor page3-empty))))) + + (testing "count-resources should return count of all result" + (is (= 4 (:count (count-resources db' {:resource/type :server + :permission :view + :subject (->user super-user-eid)}))))) + + (testing "count-resources is also cursor-sensitive" + (is (= 2 (:count (count-resources db' {:resource/type :server + :permission :view + :cursor page1-cursor + :subject (->user super-user-eid)})))) + + (is (zero? (:count (count-resources db' {:resource/type :server + :permission :view + :subject (->user super-user-eid) + :cursor page2-cursor})))))) + + (testing "now test pagination for :view permission on :account for account->super_admin with {:arrow :account :relation :super_admin}" + (let [both-pages (lookup-resources db' {:limit 3 + :cursor nil ; :cursor nil = first page. + :resource/type :account + :permission :view + :subject (->user super-user-eid)}) + + both-pages-resolved (paginated-data->spice db' (:data both-pages)) + [page1-expected page2-expected] (partition-all 1 both-pages-resolved) + page3-expected [] ; empty. + + {:as page1 + page1-data :data + page1-cursor :cursor} (lookup-resources db' {:limit 1 + :cursor nil ; no cursor should the first page. + :resource/type :account + :permission :view + :subject (->user super-user-eid)}) + ;_ (prn 'page1 'cursor (:cursor page1)) + {:as page2 + page2-data :data + page2-cursor :cursor} (lookup-resources db' {:limit 1 + :cursor (:cursor page1) + :resource/type :account + :permission :view + :subject (->user super-user-eid)}) + {:as page3-empty + page3-data :data + page3-cursor :cursor} (->> (lookup-resources db' {:limit 2 + :cursor (:cursor page2) + :resource/type :account + :permission :view + :subject (->user super-user-eid)}))] + + ;_ (prn 'page2 'cursor (:cursor page2))] + + (testing "page1 cursor points to next page" + (is page1-cursor) + (is (:e page1-cursor))) + + (testing "page2 cursor points to next page" + (is page2-cursor) + (is (:e page2-cursor))) + + (testing "page3 cursor matches page 2 because we exhausted results on page 2" + ; TODO: figure out what this should return. The previous cursor? + ; we probably need a flag for empty, but empty :data implies that. + (is (= page2-cursor page3-cursor))) + + ;(prn 'both-pages both-pages) + + (testing "both-pages :limit 3 should include both results, in sorted order" ; (depends on tuple index or costly sort) + (is (= [(spice-object :account "account-1") + (spice-object :account "account-2")] + (paginated-data->spice db' (:data both-pages))))) + + (testing "page1 contains first result only (no. 1 of 2" + (is (= page1-expected (paginated-data->spice db' page1-data)))) + + (testing "page2 contains second result only (no. 2 of 2)" + (is (= page2-expected (paginated-data->spice db' page2-data)))) + + (testing "page3 should be empty (results exhausted)" + (is (empty? page3-expected)) + (is (empty? (paginated-data->spice db' page3-data)))) + + (testing "lookup-resources returns cursor input when looking beyond any values" + (let [page3-empty (lookup-resources db' {:limit 100 + :cursor page2-cursor + :resource/type :account + :permission :view + :subject (->user super-user-eid)})] + (is (empty? (:data page3-empty))) + (is (= page2-cursor (:cursor page3-empty))))) + + ;; server.view tests follow + (testing "count-resources & cursors" + (testing "count-resources should return count of all servers" + (is (= 4 (:count (count-resources db' {:resource/type :server + :permission :view + :subject (->user super-user-eid)})))) + + (let [{all-servers :data} (lookup-resources db' {:subject (->user super-user-eid) ; all results. + :permission :view + :resource/type :server + :limit -1 + :cursor nil})] + (is (= [(spice-object :server "account1-server1") + (spice-object :server "account1-server2") + (spice-object :server "account2-server1") + (spice-object :server "server-3")] + (paginated-data->spice db' all-servers)))) + + (let [{page1-servers :data + page1-cursor :cursor} (lookup-resources db' {:subject (->user super-user-eid) ; all results. + :permission :view + :resource/type :server + :limit 2 + :cursor nil})] + (is (:e page1-cursor)) + (is (= [(spice-object :server "account1-server1") + (spice-object :server "account1-server2")] + (paginated-data->spice db' page1-servers))) + + (let [{page2-servers :data + page2-cursor :cursor} (lookup-resources db' {:subject (->user super-user-eid) ; all results. + :permission :view + :resource/type :server + :limit 2 + :cursor page1-cursor})] + (is (:e page2-cursor)) + (is (= [(spice-object :server "account2-server1") + (spice-object :server "server-3")] + (paginated-data->spice db' page2-servers))) + + ; these are broken because we are passing account cursors in tests. + (testing "count-resources should respect limit & cursors" + (is (:e page1-cursor)) + (is (:e page2-cursor)) + (is (not= page1-cursor page2-cursor)) + + (is (= 2 (:count (count-resources db' + {:resource/type :server + :permission :view + :limit 2 + :cursor nil + :subject (->user super-user-eid)})))) + + (is (= 2 (:count (count-resources db' + {:resource/type :server + :permission :view + :limit 2 + :cursor page1-cursor + :subject (->user super-user-eid)})))) + + (is (= 0 (:count (count-resources db' + {:resource/type :server + :permission :view + :limit 10 + :subject (->user super-user-eid) + :cursor page2-cursor})))))))))))))))) + +(deftest permission-schema-helper-tests + (let [db (d/db *conn*)] + + ; skipped for now. + #_(testing "find-relation-def returns nil if called with any nil inputs" + (is (nil? (impl.indexed/find-relation-def db nil nil))) + (is (nil? (impl.indexed/find-relation-def db nil :something))) + (is (nil? (impl.indexed/find-relation-def db :something nil)))) + + ;(testing "find-relation-def" + ; (is (= {:eacl.relation/subject-type :account + ; :eacl.relation/resource-type :server + ; :eacl.relation/relation-name :account} + ; (impl.indexed/find-relation-def db :server :account)))) + + (testing "find-permission-defs" + (is (pos? (count (impl.indexed/find-permission-defs db :server :view)))) + (is (empty? (impl.indexed/find-permission-defs db :server :nonexistent)))))) + +(deftest get-permission-paths-tests + (let [db (d/db *conn*)] + (testing "Direct permission paths" + (let [paths (impl.indexed/get-permission-paths db :account :view)] + ;; :account :view has direct (owner) and arrow (platform->super_admin) paths + ;; Direct owner now returns two paths due to polymorphic :user and :group + (is (= 3 (count paths))) + (is (some #(and (= (:type %) :relation) + (= (:name %) :owner) + (= (:subject-type %) :user)) + paths)) + (is (some #(and (= (:type %) :relation) + (= (:name %) :owner) + (= (:subject-type %) :group)) + paths)) + (is (some #(and (= (:type %) :arrow) + (= (:via %) :platform) + (= (:target-type %) :platform)) + paths)))) + + (testing "Arrow permission to permission" + (let [paths (impl.indexed/get-permission-paths db :vpc :admin)] + ;; Should have arrow to account->admin + (is (some #(and (= (:type %) :arrow) + (= (:via %) :account) + (= (:target-type %) :account) + (> (count (:sub-paths %)) 0)) + paths)) + ;; The sub-paths should eventually lead to relations + (let [arrow-path (first (filter #(= (:via %) :account) paths))] + (is (vector? (:sub-paths arrow-path))) + (is (pos? (count (:sub-paths arrow-path))))))) + + (testing "Complex nested paths" + (let [paths (impl.indexed/get-permission-paths db :server :view)] + ;; Find the NIC arrow path + (let [nic-path (first (filter #(= (:via %) :nic) paths))] + (is nic-path) + (is (= :network_interface (:target-type nic-path))) + ;; The sub-paths should show NIC->view paths + (is (pos? (count (:sub-paths nic-path))))))) + + (testing "Empty paths for non-existent permission" + (is (empty? (impl.indexed/get-permission-paths db :server :nonexistent)))))) + +(deftest traverse-paths-tests + (let [db (d/db *conn*)] + (testing "Direct path traversal" + (let [user1-eid (d/entid db :test/user1) + resources (impl.indexed/traverse-permission-path db :user user1-eid :view :account nil)] + ;; User1 should be able to view account1 + (is (seq resources)) + (is (some #(= (d/entid db :test/account1) %) resources)))) + + (testing "Arrow path traversal" + (let [user1-eid (d/entid db :test/user1) + resources (impl.indexed/traverse-permission-path db :user user1-eid :view :server nil)] + ;; User1 should be able to view servers in account1 + (is (seq resources)) + (is (= [(->server "account1-server1") + (->server "account1-server2")]) + resources))) + + (testing "Complex nested path traversal" + (let [vpc1-eid (d/entid db :test/vpc1) + resources (impl.indexed/traverse-permission-path db :vpc vpc1-eid :view :server nil)] + ;; VPC1 should be able to view servers through the network chain + (is (= [(d/entid db :test/server1)] + resources)))) + + (testing "Cursor pagination" + (let [user1-eid (d/entid db :test/user1) + ;; Get first result + first-batch (impl.indexed/traverse-permission-path db :user user1-eid :view :server nil) + first-eid (first first-batch) + ;; Get next result after cursor + second-batch (impl.indexed/traverse-permission-path db :user user1-eid :view :server first-eid)] + (is (= ["account1-server1" + "account1-server2" + "account3-server3.1"] (map (comp :eacl/id #(d/entity db %)) first-batch))) + (is (= ["account1-server2" + "account3-server3.1"] (map (comp :eacl/id #(d/entity db %)) second-batch))) + (is (not= (first first-batch) (first second-batch))))))) + +(deftest lookup-resources-optimized-tests + (let [db (d/db *conn*)] + (testing "Basic lookup-resources" + (let [user1-eid (d/entid db :test/user1) + result (lookup-resources db {:subject (->user user1-eid) + :permission :view + :resource/type :server + :limit 10})] + ; this replicates bug where find-relation-def is called with resource-type = nil. + (is (= [(->server "account1-server1") + (->server "account1-server2") + (->server "account3-server3.1")] + (paginated->spice db result))))) + + (testing "Pagination with cursor" + (let [user1-eid (d/entid db :test/user1) + ;; Get first page + page1 (lookup-resources db {:subject (->user user1-eid) + :permission :view + :resource/type :server + :limit 1}) + ;; Get second page using cursor + page2 (lookup-resources db {:subject (->user user1-eid) + :permission :view + :resource/type :server + :limit 1 + :cursor (:cursor page1)}) + ;; Convert for comparison + page1-converted (paginated->spice db page1) + page2-converted (paginated->spice db page2)] + (is (= 1 (count (:data page1)))) + (is (= 1 (count (:data page2)))) + (is (not= (first page1-converted) (first page2-converted))))) + + (testing "Super user can view all servers" + (let [super-user-eid (d/entid db :user/super-user) + result (lookup-resources db {:subject (->user super-user-eid) + :permission :view + :resource/type :server + :limit 100})] + ;; Should see servers from both accounts + (is (>= (count (:data result)) 3)))))) + +(deftest lookup-resources-with-merge-tests + (let [db (d/db *conn*)] + (testing "Merge handles duplicate resources from multiple paths" + ;; Add a direct relation that overlaps with arrow permission + @(d/transact *conn* + (impl/tx-relationship (d/db *conn*) + (Relationship (->user :test/user1) :shared_admin (->server :test/server1)))) + (let [db' (d/db *conn*) + user1-eid (d/entid db' :test/user1) + result (impl.indexed/lookup-resources db' {:subject (->user user1-eid) + :permission :view + :resource/type :server + :limit 10})] + ;; Should still only see each server once + (is (= [(->server "account1-server1") + (->server "account1-server2") + (->server "account3-server3.1")] + (paginated->spice db' result))))) + + (testing "Lazy merge preserves sort order" + (let [super-user-eid (d/entid db :user/super-user) + result (impl.indexed/lookup-resources db {:subject (->user super-user-eid) + :permission :view + :resource/type :server + :limit 100}) + eids (map :id (:data result))] + ;; Entity IDs should be in ascending order + (is (= eids (sort eids))))) + + (testing "Cursor works with merged results" + (let [super-user-eid (d/entid db :user/super-user) + both-pages (impl.indexed/lookup-resources db {:subject (->user super-user-eid) + :permission :view + :resource/type :server + :limit 4}) + page1 (impl.indexed/lookup-resources db {:subject (->user super-user-eid) + :permission :view + :resource/type :server + :limit 2}) + page2 (impl.indexed/lookup-resources db {:subject (->user super-user-eid) + :permission :view + :resource/type :server + :limit 2 + :cursor (:cursor page1)}) + page1+page2-data (apply concat (map :data [page1 page2])) + all-eids (map :id page1+page2-data)] + ;; No duplicates across pages + (is (= (:data both-pages) page1+page2-data)) + (is (= (count all-eids) (count (distinct all-eids)))) + ;; Results are in order + (is (= all-eids (sort all-eids))))))) + +(deftest can-optimized-tests + (let [db (d/db *conn*)] + (testing "Direct permission check" + (is (impl.indexed/can? db (->user :test/user1) :view (->account :test/account1))) + (is (not (impl.indexed/can? db (->user :test/user2) :view (->account :test/account1))))) + + (testing "Arrow permission check" + ;; User1 can view server1 through account admin + (is (impl.indexed/can? db (->user :test/user1) :view (->server :test/server1))) + (is (impl.indexed/can? db (->user :test/user1) :start (->server :test/server1))) + ;; User2 cannot view server1 + (is (not (impl.indexed/can? db (->user :test/user2) :view (->server :test/server1)))) + (is (not (impl.indexed/can? db (->user :test/user2) :start (->server :test/server1))))) + + (testing "Super user permissions" + (is (impl.indexed/can? db (->user :user/super-user) :view (->server :test/server1))) + (is (impl.indexed/can? db (->user :user/super-user) :view (->server :test/server2)))) + + (testing "Complex nested permissions" + ;; VPC can view server through network chain + (is (impl.indexed/can? db (->vpc :test/vpc1) :view (->server :test/server1))) + (is (not (impl.indexed/can? db (->vpc :test/vpc2) :view (->server :test/server1))))))) + +; uncommented because server :owner relation went away. +;(testing "Performance - early termination" +; ;; Add multiple paths that grant the same permission +; @(d/transact *conn* [(Relationship (->user :test/user1) :owner (->server :test/server1))]) +; (let [db' (d/db *conn*)] +; ;; Should still be fast even with multiple valid paths +; (is (impl.indexed/can? db' (->user :test/user1) :view (->server :test/server1))))))) + +(deftest reproduce-infinite-recursion-test + (testing "lookup-resources should handle cyclic permissions without throwing" + ;; Introduce a dependency cycle: + ;; server/view -> server/admin -> account/admin -> server/view + @(d/transact *conn* + [;; 1. Relation for account to have a primary server + (Relation :account :server-cycle :server) + ;; 2. Permission making account/admin depend on server/view, completing the cycle. + (Permission :account :admin {:arrow :server-cycle :permission :view})]) + + ;; 3. Create a relationship connecting a specific account and server. + @(d/transact *conn* + (impl/tx-relationship (d/db *conn*) + (Relationship (->server :test/server1) :server-cycle (->account :test/account1)))) + + (let [db' (d/db *conn*)] + ;; This call will trigger the infinite recursion in get-permission-paths + ;; when checking for :view on a :server. The expected behavior is an exception, + ;; which this test confirms. A proper fix would involve adding cycle detection + ;; to get-permission-paths. + + ; this causes infinite loop because we do not guard against loops yet. + ; this should be prevented at schema write time, not runtime. + (testing "cycles should not throw (we return empty), as they should be prevented at schema write time" + (is (lookup-resources db' + {:subject (->user :test/user1) + :permission :view + :resource/type :server})))))) + +(deftest permission-paths-caching-test + (let [db (d/db *conn*)] + (testing "Caching of permission paths" + (impl.indexed/evict-permission-paths-cache!) + + (let [calc-calls (atom 0) + orig-calc impl.indexed/calc-permission-paths] + (with-redefs [impl.indexed/calc-permission-paths (fn [& args] + (swap! calc-calls inc) + (apply orig-calc args))] + ;; First call - should compute + (let [paths1 (impl.indexed/get-permission-paths db :account :view)] + (is (pos? (count paths1))) + (is (pos? @calc-calls) "Should have called calc-permission-paths") + + (reset! calc-calls 0) + + ;; Second call - should be cached + (let [paths2 (impl.indexed/get-permission-paths db :account :view)] + (is (pos? (count paths2))) + (is (= paths1 paths2)) + (is (zero? @calc-calls) "Should use cache, not call calc-permission-paths") + + ;; Evict cache + (impl.indexed/evict-permission-paths-cache!) + + ;; Third call - should recompute + (let [paths3 (impl.indexed/get-permission-paths db :account :view)] + (is (pos? (count paths3))) + (is (pos? @calc-calls) "Should call calc-permission-paths after eviction"))))))))) + +(deftest permission-paths-cache-is-scoped-per-database-test + (with-mem-conn [conn1 schema/v6-schema] + (with-mem-conn [conn2 schema/v6-schema] + @(d/transact conn1 fixtures/relations+permissions) + @(d/transact conn1 fixtures/entity-fixtures) + @(d/transact conn2 fixtures/relations+permissions) + @(d/transact conn2 fixtures/entity-fixtures) + + (impl.indexed/evict-permission-paths-cache!) + + (impl.indexed/get-permission-paths (d/db conn1) :server :view) + (impl.indexed/get-permission-paths (d/db conn2) :server :view) + + (is (= 2 (count @impl.indexed/permission-paths-cache)) + "Permission path caching must not leak DB-specific relation eids across databases")))) diff --git a/modules/eacl-datomic/test/eacl/datomic/parser_test.clj b/modules/eacl-datomic/test/eacl/datomic/parser_test.clj new file mode 100644 index 000000000..9a4829cac --- /dev/null +++ b/modules/eacl-datomic/test/eacl/datomic/parser_test.clj @@ -0,0 +1,155 @@ +(ns eacl.datomic.parser_test + (:require [clojure.test :as t :refer [deftest testing is]] + [instaparse.core :as insta] + [eacl.spicedb.parser :as parser] + [eacl.datomic.impl :as impl])) + +(def example-schema-string + "definition user {} + + definition platform { + relation super_admin: user + } + + definition account { + relation platform: platform + relation owner: user + + permission admin = owner + platform->super_admin + permission view = owner + admin + permission update = admin + }") + +;; Expected parse tree for the new full SpiceDB grammar +(def parsed-example-schema + [:schema + [:definition [:type-path [:identifier "user"]] [:definition-body]] + [:definition [:type-path [:identifier "platform"]] + [:definition-body + [:relation [:relation-name [:identifier "super_admin"]] + [:relation-type-expr [:relation-type-ref [:type-path [:identifier "user"]]]]]]] + [:definition [:type-path [:identifier "account"]] + [:definition-body + [:relation [:relation-name [:identifier "platform"]] + [:relation-type-expr [:relation-type-ref [:type-path [:identifier "platform"]]]]] + [:relation [:relation-name [:identifier "owner"]] + [:relation-type-expr [:relation-type-ref [:type-path [:identifier "user"]]]]] + [:permission [:identifier "admin"] + [:permission-expr + [:union-expr + [:intersect-expr [:exclusion-expr [:arrow-expr [:simple-arrow-expr [:base-expr [:identifier "owner"]]]]]] + [:intersect-expr [:exclusion-expr [:arrow-expr [:simple-arrow-expr [:base-expr [:identifier "platform"]] [:base-expr [:identifier "super_admin"]]]]]]]]] + [:permission [:identifier "view"] + [:permission-expr + [:union-expr + [:intersect-expr [:exclusion-expr [:arrow-expr [:simple-arrow-expr [:base-expr [:identifier "owner"]]]]]] + [:intersect-expr [:exclusion-expr [:arrow-expr [:simple-arrow-expr [:base-expr [:identifier "admin"]]]]]]]]] + [:permission [:identifier "update"] + [:permission-expr + [:union-expr + [:intersect-expr [:exclusion-expr [:arrow-expr [:simple-arrow-expr [:base-expr [:identifier "admin"]]]]]]]]]]]]) + +(deftest spicedb-schema-parsing-tests + + (testing "we can parse an empty resource definition" + (is (= [:schema + [:definition [:type-path [:identifier "user"]] + [:definition-body]]] (parser/parse-schema "definition user {}")))) + + ;; Permission expressions have new structure with union/intersect/exclusion/arrow hierarchy + (testing "we can parse permission expressions with union" + (let [parsed (parser/parse-permission-expression "owner + admin")] + ;; Just verify it parses and has the expected shape + (is (= :permission-expr (first parsed))) + (is (= :union-expr (first (second parsed)))))) + + (testing "we can parse arrow permissions with one level of nesting" + (let [parsed (parser/parse-permission-expression "owner + account->admin")] + (is (= :permission-expr (first parsed))) + ;; Verify arrow structure exists + (is (some #(= :simple-arrow-expr (first %)) (tree-seq vector? rest parsed))))) + + (testing "we can parse Spice schema DSL using Instaparse" + (let [parse-tree (parser/parse-schema example-schema-string)] + (is (= parsed-example-schema parse-tree)) + + (testing "we can extract resource definitions w/relations + permissions" + (let [definitions (parser/extract-definitions parse-tree)] + (is (= #{"user" "platform" "account"} (set (keys definitions)))))) + + (testing "we can coerce definitions to EACL schema maps" + (let [eacl-schema (parser/->eacl-schema parse-tree) + relations (:relations eacl-schema) + permissions (:permissions eacl-schema)] + (is (= #{(impl/Relation :platform :super_admin :user) + (impl/Relation :account :platform :platform) + (impl/Relation :account :owner :user)} + (set relations))) + + (is (= #{(impl/Permission :account :admin {:relation :owner}) + (impl/Permission :account :admin {:arrow :platform :relation :super_admin}) + (impl/Permission :account :view {:relation :owner}) + (impl/Permission :account :view {:permission :admin}) + (impl/Permission :account :update {:permission :admin})} + (set permissions))))))) + + (testing "ensure we warn against unsupported Spice schema like exclusion permissions")) + +(deftest unsupported-features-tests + (testing "exclusion operator (-) is rejected during validation" + (let [schema "definition user {} + definition account { + relation owner: user + relation guest: user + permission admin = owner - guest + }"] + ;; Grammar now parses it, but validation rejects it + (is (thrown-with-msg? clojure.lang.ExceptionInfo #"Unsupported operator: Exclusion" + (parser/->eacl-schema (parser/parse-schema schema)))))) + + (testing "intersection operator (&) is rejected during validation" + (let [schema "definition a { + relation b: user + relation c: user + permission p = b & c + }"] + (is (thrown-with-msg? clojure.lang.ExceptionInfo #"Unsupported operator: Intersection" + (parser/->eacl-schema (parser/parse-schema schema)))))) + + (testing "multi-level arrow is rejected during validation" + ;; Grammar now parses multi-arrows, but validation rejects them + (let [schema "definition a { relation b: b } + definition b { relation c: c } + definition c { permission p = b->c->x }"] + (is (thrown-with-msg? clojure.lang.ExceptionInfo #"Unsupported feature: Multi-level arrows" + (parser/->eacl-schema (parser/parse-schema schema)))))) + + (testing "wildcard relations are rejected during validation" + (let [schema "definition doc { relation viewer: user:* }"] + (is (thrown-with-msg? clojure.lang.ExceptionInfo #"Unsupported feature: Wildcard relation" + (parser/->eacl-schema (parser/parse-schema schema)))))) + + (testing "subject relations are rejected during validation" + (let [schema "definition doc { relation owner: group#member }"] + (is (thrown-with-msg? clojure.lang.ExceptionInfo #"Unsupported feature: Subject relation" + (parser/->eacl-schema (parser/parse-schema schema)))))) + + (testing "caveats are rejected during validation" + (let [schema "definition doc { relation viewer: user with ip_check }"] + (is (thrown-with-msg? clojure.lang.ExceptionInfo #"Unsupported feature: Caveat" + (parser/->eacl-schema (parser/parse-schema schema)))))) + + (testing "nil keyword is rejected during validation" + (let [schema "definition doc { permission p = nil }"] + (is (thrown-with-msg? clojure.lang.ExceptionInfo #"Unsupported keyword: 'nil'" + (parser/->eacl-schema (parser/parse-schema schema)))))) + + (testing "self keyword is rejected during validation" + (let [schema "definition user { permission view = self }"] + (is (thrown-with-msg? clojure.lang.ExceptionInfo #"Unsupported keyword: 'self'" + (parser/->eacl-schema (parser/parse-schema schema)))))) + + (testing ".all() arrow function is rejected during validation" + (let [schema "definition doc { relation group: group permission view = group.all(member) }"] + (is (thrown-with-msg? clojure.lang.ExceptionInfo #"Unsupported function: \.all\(\)" + (parser/->eacl-schema (parser/parse-schema schema))))))) \ No newline at end of file diff --git a/modules/eacl-datomic/test/eacl/datomic/performance_test.clj b/modules/eacl-datomic/test/eacl/datomic/performance_test.clj new file mode 100644 index 000000000..068e514aa --- /dev/null +++ b/modules/eacl-datomic/test/eacl/datomic/performance_test.clj @@ -0,0 +1,221 @@ +;(ns eacl.datomic.performance-test +; "Performance benchmarks for EACL optimizations" +; (:require [clojure.test :as t :refer [deftest testing is]] +; [datomic.api :as d] +; [eacl.datomic.datomic-helpers :refer [with-mem-conn]] +; [eacl.datomic.fixtures :as fixtures :refer [->user ->server ->account ->vpc]] +; [eacl.core :as eacl :refer [spice-object]] +; [eacl.datomic.schema :as schema] +; [eacl.datomic.impl :as impl :refer [Relation Relationship Permission]] +; [eacl.datomic.rules :as original-rules] +; [eacl.datomic.rules.optimized :as rules] +; [clojure.tools.logging :as log])) +; +;(defn measure-time +; "Measure execution time of a function in milliseconds" +; [f] +; (let [start (System/nanoTime) +; result (f) +; end (System/nanoTime) +; duration-ms (/ (- end start) 1000000.0)] +; {:result result +; :time-ms duration-ms})) +; +;(defn generate-test-data +; "Generate test data with specified number of users, accounts, and servers" +; [conn num-users num-accounts num-servers prefix] +; (let [users (for [i (range num-users)] +; {:db/id (str prefix "-user-" i) +; :entity/id (str prefix "-user-" i) +; :resource/type :user}) +; +; accounts (for [i (range num-accounts)] +; {:db/id (str prefix "-account-" i) +; :entity/id (str prefix "-account-" i) +; :resource/type :account}) +; +; servers (for [i (range num-servers)] +; {:db/id (str prefix "-server-" i) +; :entity/id (str prefix "-server-" i) +; :resource/type :server}) +; +; ;; Create relationships +; ;; Each user owns an account +; user-account-rels (for [i (range (min num-users num-accounts))] +; (Relationship (->user (str prefix "-user-" i)) +; :owner +; (->account (str prefix "-account-" i)))) +; +; ;; Each account has servers +; servers-per-account (quot num-servers num-accounts) +; account-server-rels (for [i (range num-accounts) +; j (range servers-per-account)] +; (Relationship (->account (str prefix "-account-" i)) +; :account +; (->server (str prefix "-server-" (+ (* i servers-per-account) j)))))] +; +; @(d/transact conn (concat users accounts servers +; user-account-rels account-server-rels)))) +; +;(defn run-performance-comparison +; "Run performance comparison between original and optimized rules" +; [db test-name query-fn original-rules optimized-rules] +; (log/debug (str "\n" test-name ":")) +; +; ;; Test with original rules +; (let [{:keys [time-ms result]} (measure-time #(query-fn db original-rules))] +; (log/debug (format " Original: %.2f ms (found %d results)" +; time-ms (count result)))) +; +; ;; Test with optimized rules +; (let [{:keys [time-ms result]} (measure-time #(query-fn db optimized-rules))] +; (log/debug (format " Optimized: %.2f ms (found %d results)" +; time-ms (count result))))) +; +;(deftest performance-comparison-test +; (testing "Performance comparison between original and optimized rules" +; (with-mem-conn [conn schema/v5-schema] +; ;; Set up base schema +; @(d/transact conn fixtures/base-fixtures) +; +; ;; Generate larger test dataset +; (log/debug "\nGenerating test data...") +; (generate-test-data conn 100 20 500 "perf1") +; +; (let [db (d/db conn)] +; +; ;; Test can? performance +; (run-performance-comparison +; db "can? check (direct permission)" +; (fn [db rules] +; (let [subject (d/entity db [:entity/id "perf1-user-0"]) +; resource (d/entity db [:entity/id "perf1-server-0"])] +; (log/debug 'subject subject 'resource resource) +; (d/q '[:find ?subject +; :in $ % ?subject ?perm ?resource +; :where +; (has-permission ?subject ?perm ?resource)] +; db rules +; (:db/id subject) +; :view +; (:db/id resource)))) +; original-rules/check-permission-rules +; rules/check-permission-rules) +; +; ;; Test lookup-subjects performance +; (run-performance-comparison +; db "lookup-subjects (find who can view server-0)" +; (fn [db rules] +; (let [resource (d/entity db [:entity/id "perf1-server-0"])] +; (d/q '[:find [?subject ...] +; :in $ % ?subject-type ?permission ?resource-eid +; :where +; (has-permission ?subject-type ?subject ?permission ?resource-eid) +; [(not= ?subject ?resource-eid)]] +; db rules +; :user +; :view +; (:db/id resource)))) +; original-rules/rules-lookup-subjects +; rules/rules-lookup-subjects) +; +; ;; Test lookup-resources performance (highest priority) +; (run-performance-comparison +; db "lookup-resources (find servers user-0 can view)" +; (fn [db rules] +; (let [subject (d/entity db [:entity/id "perf1-user-0"])] +; (d/q '[:find [?resource ...] +; :in $ % ?subject-type ?subject-eid ?permission ?resource-type +; :where +; (has-permission ?subject-type ?subject-eid ?permission ?resource-type ?resource)] +; db rules +; :user +; (:db/id subject) +; :view +; :server))) +; original-rules/rules-lookup-resources +; rules/rules-lookup-resources) +; +; ;; Test with larger dataset +; (log/debug "\n\nGenerating larger test dataset...") +; (generate-test-data conn 500 100 2000 "perf2") +; (let [db-large (d/db conn)] +; +; (log/debug "\nLarger dataset tests:") +; +; ;; Test lookup-resources with larger dataset +; (run-performance-comparison +; db-large "lookup-resources on larger dataset" +; (fn [db rules] +; (let [subject (d/entity db [:entity/id "perf2-user-10"])] +; (d/q '[:find [?resource ...] +; :in $ % ?subject-type ?subject-eid ?permission ?resource-type +; :where +; (has-permission ?subject-eid ?permission ?resource-type ?resource) +; [?resource :resource/type ?resource-type]] +; db rules +; :user +; (:db/id subject) +; :view +; :server))) +; original-rules/rules-lookup-resources +; rules/rules-lookup-resources)))))) +; +;(deftest staged-lookup-resources-test +; (testing "Staged lookup-resources implementation" +; (with-mem-conn [conn schema/v5-schema] +; @(d/transact conn fixtures/base-fixtures) +; (generate-test-data conn 100 20 100000 "staged") +; +; (let [db (d/db conn)] +; (log/debug "\n\nStaged lookup-resources test:") +; +; ;; Test original implementation +; (let [{:keys [time-ms result]} +; (measure-time +; #(impl/lookup-resources db {:resource/type :server +; :permission :view +; :subject (->user "staged-user-5") +; :limit 5000000}))] +; (log/debug (format " Full implementation: %.2f ms (found %d results)" +; time-ms (count result))))))) +; +; (testing "Staged lookup-resources with limit & offset implementation" +; (with-mem-conn [conn schema/v5-schema] +; @(d/transact conn fixtures/base-fixtures) +; (generate-test-data conn 100 20 100000 "staged") +; +; (let [db (d/db conn)] +; (log/debug "\n\nStaged lookup-resources test with limit & offset:") +; +; ;; Test original implementation +; (let [{:keys [time-ms result]} +; (measure-time +; #(impl/lookup-resources db {:offset 2000 +; :limit 1500 +; :resource/type :server +; :permission :view +; :subject (->user "staged-user-5")}))] +; (log/debug (format " Full implementation: %.2f ms (found %d results)" +; time-ms (count result))))))) +; +; (testing "Staged lookup-resources with small limit, large offset" +; (with-mem-conn [conn schema/v5-schema] +; @(d/transact conn fixtures/base-fixtures) +; (generate-test-data conn 100 20 100000 "staged") +; +; (let [db (d/db conn)] +; (log/debug "\n\nStaged lookup-resources test with small limit, large offset:") +; +; ;; Test original implementation +; (let [{:keys [time-ms result]} +; (measure-time +; #(impl/lookup-resources db {:offset 2000 +; :limit 20 +; :resource/type :server +; :permission :view +; :subject (->user "staged-user-5")}))] +; (log/debug (format " Full implementation: %.2f ms (found %d results)" +; time-ms (count result)))))))) +; +;;; Run with: clj -M:test -n eacl.datomic.performance-test \ No newline at end of file diff --git a/modules/eacl-datomic/test/eacl/datomic/schema_test.clj b/modules/eacl-datomic/test/eacl/datomic/schema_test.clj new file mode 100644 index 000000000..05568f0d1 --- /dev/null +++ b/modules/eacl-datomic/test/eacl/datomic/schema_test.clj @@ -0,0 +1,230 @@ +(ns eacl.datomic.schema-test + (:require [clojure.test :as t :refer [deftest testing is]] + [datomic.api :as d] + [eacl.datomic.datomic-helpers :refer [with-mem-conn]] + [eacl.datomic.schema :as schema] + [eacl.datomic.fixtures :as fixtures] + [eacl.datomic.impl :as impl])) + +(def example-schema-string + "definition user {} + + definition platform { + relation super_admin: user + } + + definition account { + relation platform: platform + relation owner: user + + permission admin = owner + platform->super_admin + permission view = owner + admin + permission update = admin + }") + +(deftest eacl-schema-stable-ident-tests + (with-mem-conn [conn schema/v6-schema] + (testing "we can transact Realtions & Permissions twice without datom conflicts after introduction of :eacl/id for Relation & Permission." + (is @(d/transact conn fixtures/relations+permissions)) + (is @(d/transact conn fixtures/relations+permissions)) + (is (schema/read-schema (d/db conn)))))) + +(deftest eacl-schema-comparison-tests + (testing "we can calculate additions & retractions" + ; note we do not care about shape of set elements here. + (is (= {:additions #{:added} + :unchanged #{:retained} + :retractions #{:deleted}} + (schema/calc-set-deltas + #{:deleted :retained} + #{:retained :added}))) + + (is (= {:relations {:additions #{:added} + :unchanged #{:retained} + :retractions #{:deleted}} + :permissions {:additions #{:added} + :unchanged #{:retained} + :retractions #{:deleted :also-deleted}}} + (schema/compare-schema + {:relations [:deleted :retained] + :permissions [:deleted :retained :also-deleted]} + {:relations [:retained :added] + :permissions [:retained :added]}))))) + +(deftest write-schema-test + (with-mem-conn [conn schema/v6-schema] + (testing "Initial schema write" + (let [deltas (schema/write-schema! conn example-schema-string) + db (d/db conn) + schema (schema/read-schema db)] + (is (= 3 (count (:relations schema)))) + (is (= 5 (count (:permissions schema)))) + (is (= 3 (count (:additions (:relations deltas))))) + (is (= 5 (count (:additions (:permissions deltas))))) + + ;; Verify schema string is stored + (is (= example-schema-string (:eacl/schema-string (d/entity db [:eacl/id "schema-string"])))))) + + (testing "Update schema (no changes)" + (let [deltas (schema/write-schema! conn example-schema-string)] + (is (empty? (:additions (:relations deltas)))) + (is (empty? (:retractions (:relations deltas)))) + (is (empty? (:additions (:permissions deltas)))) + (is (empty? (:retractions (:permissions deltas)))))) + + (testing "Update schema (add relation)" + (let [new-schema (str example-schema-string "\ndefinition new_res { relation new_rel: user }") + deltas (schema/write-schema! conn new-schema) + db (d/db conn) + schema (schema/read-schema db)] + (is (= 4 (count (:relations schema)))) + (is (= 1 (count (:additions (:relations deltas))))))) + + (testing "Update schema (remove relation - safe)" + (let [deltas (schema/write-schema! conn example-schema-string) ; revert to original + db (d/db conn) + schema (schema/read-schema db)] + (is (= 3 (count (:relations schema)))) + (is (= 1 (count (:retractions (:relations deltas))))))) + + (testing "Update schema (remove relation - unsafe)" + ;; Create a relationship using a relation + (let [user-id "user1" + acc-id "acc1"] + @(d/transact conn [{:db/id user-id :eacl/id "user1"} + {:db/id acc-id :eacl/id "acc1"}]) + @(d/transact conn (impl/tx-relationship (d/db conn) + (impl/Relationship {:type :user :id user-id} :owner {:type :account :id acc-id}))) + + ;; Verify relationship exists + (let [db (d/db conn) + rel (impl/find-one-relationship-id db + {:subject {:type :user :id user-id} + :relation :owner + :resource {:type :account :id acc-id}})] + (is rel "Relationship should exist"))) + + ;; Try to remove 'relation owner: user' from account + (let [unsafe-schema "definition user {} + definition platform { relation super_admin: user } + definition account { relation platform: platform }"] ; removed owner + (is (thrown-with-msg? clojure.lang.ExceptionInfo #"Cannot delete relation :owner because it is used by 1 relationships" + (schema/write-schema! conn unsafe-schema))))))) + +(deftest schema-validation-tests + "Tests for ADR 012 requirement: 'Invalid schema should be rejected and no changes made.'" + + (testing "permission referencing non-existent relation is rejected" + (with-mem-conn [conn schema/v6-schema] + (let [bad-schema "definition user {} + definition account { + permission admin = nonexistent_relation + }"] + (is (thrown-with-msg? clojure.lang.ExceptionInfo #"Invalid schema" + (schema/write-schema! conn bad-schema)))))) + + (testing "arrow permission with invalid target is rejected" + (with-mem-conn [conn schema/v6-schema] + (let [bad-schema "definition user {} + definition account { relation owner: user } + definition server { + relation account: account + permission view = account->nonexistent + }"] + (is (thrown-with-msg? clojure.lang.ExceptionInfo #"Invalid schema" + (schema/write-schema! conn bad-schema)))))) + + (testing "self-permission referencing non-existent permission is rejected" + (with-mem-conn [conn schema/v6-schema] + (let [bad-schema "definition user {} + definition server { + permission view = fake_permission + }"] + (is (thrown-with-msg? clojure.lang.ExceptionInfo #"Invalid schema" + (schema/write-schema! conn bad-schema)))))) + + (testing "arrow permission with missing source relation is rejected" + (with-mem-conn [conn schema/v6-schema] + (let [bad-schema "definition user {} + definition account { relation owner: user } + definition server { + permission view = missing_relation->admin + }"] + ;; Error comes from parser's resolve-component (validates during parse) + (is (thrown-with-msg? clojure.lang.ExceptionInfo #"Unknown relation" + (schema/write-schema! conn bad-schema)))))) + + (testing "valid schema is accepted" + (with-mem-conn [conn schema/v6-schema] + (let [good-schema "definition user {} + definition platform { relation super_admin: user } + definition account { + relation platform: platform + relation owner: user + permission admin = owner + platform->super_admin + permission view = admin + }"] + (is (schema/write-schema! conn good-schema)) + (let [db (d/db conn) + schema (schema/read-schema db)] + (is (= 3 (count (:relations schema)))) + (is (= 3 (count (:permissions schema))))))))) + +(deftest fixtures-schema-round-trip-test + "Tests that fixtures.schema can be written and read back correctly. + ADR 012 requirement: 'Rewrite the fixtures... to a new test/eacl/fixtures.schema file'" + (with-mem-conn [conn schema/v6-schema] + (let [schema-string (slurp "test/eacl/fixtures.schema") + _ (schema/write-schema! conn schema-string) + db (d/db conn) + schema (schema/read-schema db) + relations (:relations schema) + permissions (:permissions schema)] + + (testing "multi-type relations are expanded correctly" + ;; account/owner should have both user and group subject types + (let [account-owner-rels (filter #(and (= :account (:eacl.relation/resource-type %)) + (= :owner (:eacl.relation/relation-name %))) + relations)] + (is (= #{:user :group} (set (map :eacl.relation/subject-type account-owner-rels)))))) + + (testing "platform/super_admin relation exists" + (is (some #(= (impl/Relation :platform :super_admin :user) %) relations))) + + (testing "server/account relation exists" + (is (some #(= (impl/Relation :server :account :account) %) relations))) + + (testing "vpc/shared_admin relation exists" + (is (some #(= (impl/Relation :vpc :shared_admin :user) %) relations))) + + (testing "account/admin permission has correct definitions" + ;; permission admin = owner + platform->super_admin + (let [account-admin-perms (filter #(and (= :account (:eacl.permission/resource-type %)) + (= :admin (:eacl.permission/permission-name %))) + permissions)] + (is (= #{(impl/Permission :account :admin {:relation :owner}) + (impl/Permission :account :admin {:arrow :platform :relation :super_admin})} + (set account-admin-perms))))) + + (testing "server/view permission has correct definitions" + ;; permission view = admin + nic->view + shared_member + backup_creator + (let [server-view-perms (filter #(and (= :server (:eacl.permission/resource-type %)) + (= :view (:eacl.permission/permission-name %))) + permissions)] + (is (= #{(impl/Permission :server :view {:permission :admin}) + (impl/Permission :server :view {:arrow :nic :permission :view}) + (impl/Permission :server :view {:relation :shared_member}) + (impl/Permission :server :view {:relation :backup_creator})} + (set server-view-perms))))) + + (testing "vpc/admin permission has correct definitions" + ;; permission admin = account->admin + shared_admin + (let [vpc-admin-perms (filter #(and (= :vpc (:eacl.permission/resource-type %)) + (= :admin (:eacl.permission/permission-name %))) + permissions)] + (is (= #{(impl/Permission :vpc :admin {:arrow :account :permission :admin}) + (impl/Permission :vpc :admin {:relation :shared_admin})} + (set vpc-admin-perms))))) + + (testing "schema string is stored" + (is (= schema-string (:eacl/schema-string (d/entity db [:eacl/id "schema-string"])))))))) diff --git a/modules/eacl-datomic/test/eacl/report_queue.clj b/modules/eacl-datomic/test/eacl/report_queue.clj new file mode 100644 index 000000000..db0dc29ca --- /dev/null +++ b/modules/eacl-datomic/test/eacl/report_queue.clj @@ -0,0 +1,110 @@ +(ns eacl.report-queue + (:require [datomic.api :as d] + [clojure.test :as t :refer [deftest testing is]] + [eacl.datomic.datomic-helpers :refer [with-mem-conn]] + [clojure.core.async :as a] + [clojure.tools.logging :as log])) + +(defn missing-entity? + "Returns true if no :eavt datoms for this eid. + Can be used to detect new entities or fully retracted entities. + + impl. of empty? does (not (seq coll))." + [db eid] + (empty? (d/datoms db :eavt eid))) + +(defn make-managed-listener + "Returns {:keys [stop-fn listener]}." + [conn handler on-stop timeout-ms] ; todo timeout. + (let [report-queue (d/tx-report-queue conn) + !stop-signal (atom false) + stop-fn #(reset! !stop-signal true) + listener-future (future + (try + (loop [] + (if @!stop-signal + (do + (log/debug "Stopping managed tx-report-queue listener.") + (on-stop)) + (let [timeout-chan (a/timeout timeout-ms) + report-chan (a/thread (.take report-queue))] + (a/alt!! + report-chan ([report] + (when report ; can be nil? + (try + (handler report) + (catch Exception ex + (log/error "Error processing tx-report:" ex)))) + (recur)) + ; timeout is expected. + timeout-chan (recur))))) + (catch InterruptedException ex + (log/warn "Listener interrupted: " (.getMessage ex))) + (catch Exception ex + (log/warn "Unexpected error in listener: " (.getMessage ex)))))] + {:listener-future listener-future + :stop-fn stop-fn})) + +(with-mem-conn [conn [{:db/ident :server/name + :db/valueType :db.type/string + :db/cardinality :db.cardinality/one} + + {:db/ident :server/ram-mib + :db/valueType :db.type/long + :db/cardinality :db.cardinality/one}]] + (let [!stopped? (promise) + {:keys [stop-fn listener]} (make-managed-listener + conn + (fn [{:as report :keys [tx-data db-before db-after]}] + (let [eid-set (set (map :e tx-data)) + + {:as grouped-by-added + retractions false + additions true} (group-by :added tx-data) + + ; could be group-by. + retracted-eids (map :e retractions) + addition-eids (map :e additions) + + new-entity-eids (set (filter (partial missing-entity? db-before) addition-eids)) + updated-eids (set (remove (partial missing-entity? db-before) addition-eids)) ; can be optimised. + ; and here we can also inspect changed. + fully-retracted-eids (set (filter (partial missing-entity? db-after) retracted-eids))] + + ; If you want to loop over datoms: + ;(doall + ; (for [datom tx-data] + ; (log/info "datom:" (pr-str datom)))) + + ; We can use this to inform our projection layer and no diffing would be required. + ; and no diffing will be required. + + (log/info "Created:" new-entity-eids) + (log/info "Updated:" updated-eids) ; todo check logic here. + (log/info "Deleted:" fully-retracted-eids) + (log/info "Fully retracted entities:" fully-retracted-eids))) + ;(log/info "tx-data: " tx-data)) + (fn [] (deliver !stopped? true)) + 5000)] + + @(d/transact conn [{:db/ident :server1 + :server/name "Server 1" + :server/ram-mib 8} + + {:db/ident :server2 + :server/name "Server 2" + :server/ram-mib 8} + + {:db/ident :server3 + :server/name "Server 3"}]) + + @(d/transact conn [[:db/retractEntity :server1] + {:db/ident :server2 :server/ram-mib 16} + {:db/ident :server3 :server/ram-mib 32}]) + + (Thread/sleep 500) ; wait for report-queue listener to run. + + ; we need a sleep here? + (stop-fn) + ; wait for listener to stop. + @!stopped?)) \ No newline at end of file diff --git a/modules/eacl-datomic/test/eacl/spice_test.clj b/modules/eacl-datomic/test/eacl/spice_test.clj new file mode 100644 index 000000000..f8ab1d647 --- /dev/null +++ b/modules/eacl-datomic/test/eacl/spice_test.clj @@ -0,0 +1,445 @@ +(ns eacl.spice-test + (:require [clojure.string :as string] + [clojure.test :as t :refer [deftest testing is use-fixtures]] + [eacl.core :as eacl :refer [spice-object ->Relationship]] + [eacl.datomic.schema :as schema] + [datomic.api :as d] ; ideally don't want this + [eacl.datomic.datomic-helpers :refer [with-mem-conn]] + [eacl.datomic.fixtures :as fixtures :refer [->user ->team ->server ->platform ->vpc ->account]] + [eacl.datomic.core :as spiceomic] + [clojure.tools.logging :as log] + [eacl.spicedb.consistency :as consistency :refer [fully-consistent]])) + +(deftest opaque-cursor-token-test + (testing "cursor->token round-trip preserves cursor" + (let [cursor {:v 2 :e "some-id" :p {0 "intermediate-id"}} + token (spiceomic/cursor->token cursor) + decoded (spiceomic/token->cursor token)] + (is (string? token)) + (is (.startsWith ^String token "eacl1_")) + (is (= cursor decoded)))) + + (testing "nil cursor produces nil token" + (is (nil? (spiceomic/cursor->token nil)))) + + (testing "nil or invalid input returns nil cursor" + (is (nil? (spiceomic/token->cursor nil))) + (is (nil? (spiceomic/token->cursor "garbage"))) + (is (nil? (spiceomic/token->cursor "eacl1_not-valid-base64!!!")))) + + (testing "backward compat: raw cursor map passes through token->cursor" + (let [cursor {:v 2 :e 12345 :p {0 67890}}] + (is (= cursor (spiceomic/token->cursor cursor)))))) + +(deftest spicedb-helper-tests + (testing "spice-object takes [type id ?relation] and yields a SpiceObject with support for subject_relation" + (is (= #eacl.core.SpiceObject{:type :user, :id "my-user", :relation nil} + (spice-object :user "my-user"))) + (is (= #eacl.core.SpiceObject{:type :team, :id "dev-team", :relation :member} + (spice-object :team "dev-team" :member))))) + +(deftest spicedb-tests + (with-mem-conn [conn schema/v6-schema] + (testing "->user means (partial spice-object :user). Creates a SpiceObject record with {:keys [type id relation]}" + (def my-user (->user "ben")) + (def joe's-user (->user "joe")) + (def super-user (->user "andre")) + (def new-joiner (->user "new-joiner")) + + (testing "We treat subject & resource types as keywords in Clojure-land." + (is (= :user (:type my-user))) + (testing "in these fixtures IDs are strings, but you can tell EACL how resolve to/from internal ID in make-client opts" + (is (= "ben" (:id my-user)))))) + + (testing "To define a SubjectReference with a :relation (subject_relation), pass another arg to spice-object" + (let [team-member (->team "my-team" :member)] + (is (= :team (:type team-member))) + (is (= "my-team" (:id team-member))) + (is (= :member (:relation team-member))))) + + (testing "The platform definition is an abstraction to support super administrators" + (def ca-platform (->platform "platform"))) ; todo: better name + + (testing "Define some server fixtures" + (def my-server (->server "123")) + (def my-other-server (->server "456")) + (def joe's-server (->server "not-my-server"))) + + (testing "Two account fixtures" + (def my-account (->account "operativa")) + (def acme-account (->account "acme"))) + + (testing "Make a Spice client and hold onto channel for disposal later." + (let [client (spiceomic/make-client conn {})] + (is client) + ;(is (satisfies? IAuthorization client)) + ; use :spicedb/client Integrant key instead of :permissions/spicedb because we want to migrate Spice schema manually in these tests. + ;"ensure channel is a managed gRPC channel" + ;(is (= io.grpc.internal.ManagedChannelOrphanWrapper (class channel))) + + ; def *client REPL testing convenience and fewer parens. + (def *client client))) + + @(d/transact conn (concat fixtures/relations+permissions fixtures/entity-fixtures)) + @(d/transact conn (fixtures/relationship-fixtures (d/db conn))) ; temp until write-relationships + + ;(is (= [] (eacl/read-relationships *client {:resource/type :vpc}))) + ;(is (= [] (eacl/read-relationships *client {:resource/type :account}))) + ;(is (= [] (eacl/read-relationships *client {:resource/type :server}))) + + ; TODO: bring back relationship deletion tests. + ; + ;(is (= [] (d/q '{:find [(pull ?relationship [* {:eacl.relationship/resource [*] + ; :eacl.relationship/subject [*]}])] ; ?resource-type ?resource ?relation-name ?subject], + ; ;:keys [:resource/type :resource/id :resource/relation :subject/id], + ; :in [$ ?subject-type], + ; :where [[?relationship :eacl.relationship/resource ?resource] + ; ;[?resource :resource/type :server] ;?resource-type] + ; [?relationship :eacl.relationship/relation-name ?relation-name] + ; [?relationship :eacl.relationship/subject ?subject] + ; [?subject :resource/type ?subject-type]]} + ; (d/db conn) :server))) + + #_(testing "Clean up prior relationships if non-nil schema (for REPL testing)" + ; conditional due to Spice segfault when using in-memory datastore under certain conditions. + (let [?schema-string (try (eacl/read-schema *client) (catch Exception ex nil))] + (log/debug "schema:" ?schema-string) + (when true ;?schema-string + (testing "Clean up any previous :team resource-type relationships." + (try + (->> (eacl/read-relationships *client {:resource/type :team + :consistency fully-consistent}) + (eacl/delete-relationships! *client)) + (catch Exception _ex))) + + (testing "Try to clear out any prior :platform relationships. This would be destructive if connected to prod." + (try + (->> (eacl/read-relationships *client {:resource/type :platform + :consistency fully-consistent}) + (eacl/delete-relationships! *client)) + (catch Exception _))) + + (testing "Try to clear out any prior :vpc relationships. This would be destructive if connected to prod." + (try + (->> (eacl/read-relationships *client {:resource/type :vpc + :consistency fully-consistent}) + (eacl/delete-relationships! *client)) + (catch Exception _))) + + (testing "Clean up any previous :account resource-type relationships." + (try + (->> (eacl/read-relationships *client {:resource/type :account + :consistency fully-consistent}) + (eacl/delete-relationships! *client)) + (catch Exception _))) + + (testing "Clean up any previous :server resource-type relationships." + (is (->> (eacl/read-relationships *client {:resource/type :server + :consistency fully-consistent}) + (eacl/delete-relationships! *client)))))) + (try + (->> (eacl/read-relationships *client {:resource/type :server + :consistency fully-consistent}) + (eacl/delete-relationships! *client)) + (catch Exception _))) + + #_(testing "Migrate schema via IG – will throw if new schema would orphan any relationships" + (let [{:spicedb/keys [migrate]} (ig/init (igc/integrant-definition) [:spicedb/migrate])] + ;(testing ":spicedb/migrate returns a WriteSchemaResponse, which is result of eacl/write-schema!" + ; (is (= com.authzed.api.v1.SchemaServiceOuterClass$WriteSchemaResponse (class migrate)))) + (testing "Ensure we can read a valid Spice schema after :spicedb/migrate" + (let [spice-schema-string (try (eacl/read-schema *client) (catch Exception ex ""))] + (is (false? (string/blank? spice-schema-string))) + (testing "Spice schema string contains at least one Spice `definition`" + (is (re-find #"definition" spice-schema-string))))))) + + ;(testing "After deletion, read-relationships should an return empty seq for :server resources." + ; (is (= [] (eacl/read-relationships *client {:resource/type :server})))) + + (testing "Given an empty permission system, ensure no one can reboot my-server" + ; We specify consistency/fully-consistent because permissions are cached and can? defaults to minimize-latency. + (is (false? (eacl/can? *client my-user :reboot my-server fully-consistent))) + (is (false? (eacl/can? *client joe's-user :reboot my-server fully-consistent))) + (is (false? (eacl/can? *client new-joiner :reboot my-server fully-consistent))) + (is (false? (eacl/can? *client super-user :reboot my-server fully-consistent)))) + + (testing "transact the entities with :eacl/id we are about to use so [:eacl/id 'ben'] resolves" + ; TODO: this is outdated. rather test against the newer base-fixtures. + (is @(d/transact conn (for [ent [ca-platform + my-account acme-account + super-user my-user joe's-user + my-server my-other-server joe's-server]] + {:eacl/id (:id ent)})))) + + (testing "Write relationships so my-user is the :owner of my-account and my-server is in my-account. Note the order of subjects vs. resources in ->Relationship." + (let [{:as response, token :zed/token} + (eacl/create-relationships! *client + [(->Relationship my-user :owner my-account) + (->Relationship my-account :account my-server)])] + (testing "All Spice operations returns a ZedToken that can be passed to subsequent read operations to guarantee consistent cache." + (is (string? token)) + (testing "passing anything but consistency/fully-consistent throws until we have a cache to support consistency/fresh." + (is (thrown? Throwable (eacl/can? *client my-user :reboot my-server (consistency/fresh token)))))))) + + (testing "assign joe as the owner of acme-account and joe's server to acme-account" + (is (eacl/create-relationships! *client + [(->Relationship joe's-user :owner acme-account) + (->Relationship acme-account :account joe's-server)]))) + + (testing "Now, my-user can :reboot my-server but joe's-user cannot :reboot my-server" + (is (true? (eacl/can? *client my-user :reboot my-server fully-consistent))) + (is (false? (eacl/can? *client joe's-user :reboot my-server fully-consistent)))) + + (testing "Query `lookup-resources` to enumerate the resources of a given type (:server) a user can :reboot" + + ; specifying missing subject does not throw an exception, or should it? + ; this throws: + ;(is (eacl/lookup-resources *client {:subject (->user "missing-subject") ;eacl/fully-consistent + ; :permission :reboot + ; :resource/type :server + ; :consistency :fully-consistent})) + + ; We need to coerce local resource :id to a string because IDs are read back as strings until we decide if numeric coercion is desirable. + (is (= [my-server] (->> (eacl/lookup-resources *client + {:subject my-user + :permission :reboot + :resource/type :server + :cursor nil + :consistency fully-consistent}) + (:data)))) + + (is (= [joe's-server] (->> (eacl/lookup-resources *client + {:resource/type :server + :permission :reboot + :cursor nil + :subject joe's-user + :consistency fully-consistent}) + (:data))))) + + (testing "We can use `lookup-subjects` to enumerate the subjects (users) who can :reboot servers:" + ; We coerce local resource :id to string because reads come back as strings. Need to decide if coercion is desirable. + (is (= [my-user] (:data (eacl/lookup-subjects *client {:resource my-server + :permission :reboot + :subject/type :user + :consistency fully-consistent})))) + + (is (= [joe's-user] (:data (eacl/lookup-subjects *client {:resource joe's-server + :permission :reboot + :subject/type :user + :consistency fully-consistent}))))) + + (testing "joe's-user can :reboot their server, but I cannot:" + (is (true? (eacl/can? *client joe's-user :reboot joe's-server fully-consistent))) + (is (false? (eacl/can? *client my-user :reboot joe's-server fully-consistent)))) + + (testing "Permissions do not extend to my-other-server despite falling under same account, because I don't own it yet." + (is (false? (eacl/can? *client my-user :reboot my-other-server fully-consistent)))) + + (testing "Make super-user a :super_admin of the platform so they can do everything." + (is (false? (eacl/can? *client super-user :reboot my-server fully-consistent))) + (is (eacl/create-relationship! *client (->Relationship super-user :super_admin ca-platform)))) + + (testing "Super administrators for a given platform, can only control account resources that have a corresponding :platform relation." + (is (false? (eacl/can? *client super-user :reboot my-server fully-consistent))) + (is (false? (eacl/can? *client super-user :reboot my-other-server fully-consistent))) + (is (false? (eacl/can? *client super-user :reboot joe's-server fully-consistent)))) + + (testing "Now we assign both accounts to the ca-platform" + ; The order of subject/resource seems counter-intuitive, but consider that :platform + ; is a relation under my-account (the resource), so the platform is the subject. + (is (eacl/create-relationships! *client + [(->Relationship ca-platform :platform my-account) + (->Relationship ca-platform :platform acme-account)]))) + + (testing "ensure my-other-server also falls under my-account" + (is (eacl/create-relationship! *client my-account :account my-other-server))) + + (testing "Super administrators can :reboot all servers because both accounts now fall belong to ca-platform:" + (is (true? (eacl/can? *client super-user :reboot my-server fully-consistent))) + (is (true? (eacl/can? *client super-user :reboot my-other-server fully-consistent))) + (is (true? (eacl/can? *client super-user :reboot joe's-server fully-consistent))) + + (testing "...but joe's-user cannot :reboot my-server" + (is (false? (eacl/can? *client joe's-user :reboot my-server fully-consistent))))) + + (testing "We can enumerate the platform administrators with read-relationships:" + ; fixtures a bit confusing atm. + (is (= #{(->Relationship super-user :super_admin ca-platform) + (->Relationship (->user "super-user") :super_admin ca-platform)} + (set (eacl/read-relationships *client {:resource/type :platform}))))) + + (testing "We can enumerate account owners:" + (is (= #{(->Relationship my-user :owner my-account) + (->Relationship joe's-user :owner acme-account) + (->Relationship (->user "user-1") :owner (->account "account-1")) + (->Relationship (->user "user-2") :owner (->account "account-2"))} + (set (eacl/read-relationships *client {:resource/type :account + :subject/type :user}))))) + + (testing "read-relationships supports various filters:" + (testing "query platform->account" + (is (= #{(->Relationship ca-platform :platform acme-account) + (->Relationship ca-platform :platform (->account "account-1")) + (->Relationship ca-platform :platform (->account "account-2")) + (->Relationship ca-platform :platform my-account)} + (set (eacl/read-relationships *client {:resource/type :account + :subject/type :platform + :resource/relation :platform}))))) + + (testing "the same relationships show up if we omit :resource/relation" + (is (= #{(->Relationship ca-platform :platform acme-account) + (->Relationship ca-platform :platform (->account "account-1")) + (->Relationship ca-platform :platform (->account "account-2")) + (->Relationship ca-platform :platform my-account)} + (set (eacl/read-relationships *client {:resource/type :account + :subject/type :platform})))))) + + (testing "lookup-resources pagination tests" + + ;(prn 'debug 'all-results (eacl/lookup-resources *client {:limit 100 + ; :cursor nil ; no cursor means page 1. + ; :resource/type :server + ; :permission :view + ; :subject (->user "super-user")})) + + (let [{:as page1 + page1-data :data + page1-cursor :cursor} (->> (eacl/lookup-resources *client {:limit 2 + :cursor nil ; no cursor means page 1. + :resource/type :server + :permission :view + :subject (->user "super-user")})) + ;_ (prn 'page1 page1) + ;_ (prn 'page1 'cursor (:cursor page1)) + {:as page2 + page2-data :data + page2-cursor :cursor} (->> (eacl/lookup-resources *client {:limit 2 + :cursor (:cursor page1) + :resource/type :server + :permission :view + :subject (->user "super-user")}))] + + ;_ (prn 'page2 'cursor (:cursor page2)) + + ; these are currently failing. suspect order is fixed now, which is why showin gup. + ; tbh not sure how they were ever passing given the base-fixtures. + (is (= [(spice-object :server "account1-server1") + (spice-object :server "account1-server2")] + page1-data)) + + (is (= [(spice-object :server "account2-server1") + my-server] + page2-data)) + + (testing "page1 cursor should be an opaque token" + (is page1-cursor) + (is (string? page1-cursor)) + (is (.startsWith ^String page1-cursor "eacl1_"))) + + (testing "page1-cursor round-trips and :e equals the last resource ID" + (let [decoded (spiceomic/token->cursor page1-cursor)] + (is (= (:e decoded) (:id (last (:data page1))))))) + + (testing "page2-cursor round-trips and :e equals the last resource ID" + (let [decoded (spiceomic/token->cursor page2-cursor)] + (is (= (:id (last (:data page2))) (:e decoded))))))) + + (testing "count-resources returns cursor with v2 format and coerced IDs" + (let [{:keys [count cursor]} (eacl/count-resources *client + {:subject (->user "super-user") + :permission :view + :resource/type :server + :limit 2})] + (testing "count-resources returns a count" + (is (pos? count))) + + (testing "cursor should be an opaque token" + (is (string? cursor)) + (is (.startsWith ^String cursor "eacl1_"))) + + (testing "cursor round-trips to v2 with string :e" + (let [decoded (spiceomic/token->cursor cursor)] + (is (= 2 (:v decoded))) + (is (string? (:e decoded)) + "cursor :e should be coerced to external format"))))) + + (testing "count-subjects is part of the public API with cursor tokens" + (let [{:keys [count cursor]} (eacl/count-subjects *client + {:resource (->server "123") + :permission :reboot + :subject/type :user + :limit 1})] + (testing "count-subjects returns a count" + (is (= 1 count))) + + (testing "cursor should be an opaque token" + (is (string? cursor)) + (is (.startsWith ^String cursor "eacl1_"))) + + (testing "cursor round-trips to v2 with string :e" + (let [decoded (spiceomic/token->cursor cursor)] + (is (= 2 (:v decoded))) + (is (string? (:e decoded)) + "cursor :e should be coerced to external format"))))) + + (testing "spice-read-relationships results are constrained by filters for resource type & ID" + (testing "transact the test entities we are about to use" + @(d/transact conn (for [object [(->account "test-account") + (->account "other-account") + (->vpc "my-vpc") + (->vpc "other-vpc")]] + {:eacl/id (:id object)}))) + + (is (eacl/create-relationships! *client + [(->Relationship (->account "test-account") :account (->vpc "my-vpc")) + (->Relationship (->account "test-account") :account (->vpc "other-vpc")) + (->Relationship (->account "other-account") :account (->vpc "other-vpc"))])) + (is (= [(->Relationship (->account "test-account") :account (->vpc "my-vpc"))] + (eacl/read-relationships *client {:resource/type :vpc + :resource/id "my-vpc" + :resource/relation :account + :subject/type :account + :subject/id "test-account"})))))) + +; expand-permission-tree not impl. yet. +;; FIXME: These tests fail because expand-permission-tree is not implemented yet +#_(testing "We can expand permissions hierarchy for (->server 123)." + (is (= [[[[{:object (->account "operativa") + :relation :owner + :subjects [{:object (->user "ben") + :relation nil}]} + [{:object (->platform "sample-platform") + :relation :super_admin + :subjects [{:object (->user "andre") + :relation nil}]}]]] + + ; no shared_admin subjects: + [] ; don't know what this empty vector is about. + {:object (update (->server 123) :id str) + :relation :shared_admin + :subjects []}] + + ; no shared_member subjects: + {:object (update (->server 123) :id str) + :relation :shared_member + :subjects []}] (eacl/expand-permission-tree *client {:resource (->server 123) + :permission :reboot})))) + +#_(testing "Expand permissions hierarchy for joe's-server shows team member" + ; Note: numeric IDs are not coerced back from strings yet. + (is (= [[[[{:object (->account "acme") + :subjects [{:object joe's-user :relation nil}], + :relation :owner} + [{:object (->platform "sample-platform"), + :subjects [{:object (->user "andre"), :relation nil}], + :relation :super_admin}]]] + [] + {:object (->server "not-my-server"), + :subjects [], + :relation :shared_admin}] + {:object (->server "not-my-server"), + :subjects [], + :relation :shared_member}] (eacl/expand-permission-tree *client {:resource joe's-server + :permission :reboot})))) + +;; todo: test that shows behaviour of read-relationships when subject or resource is missing. diff --git a/modules/eacl/README.md b/modules/eacl/README.md new file mode 100644 index 000000000..820d317b3 --- /dev/null +++ b/modules/eacl/README.md @@ -0,0 +1,13 @@ +# `eacl` + +Core, backend-neutral EACL module. + +Responsibilities: + +- `eacl.core` protocol and public records +- cursor/token helpers and consistency semantics +- schema IR, parser, validation, and diffing +- backend SPI and shared authorization engine +- contract test fixtures and backend-neutral tests + +This module must not depend on Datomic or a logging backend. diff --git a/modules/eacl/build.clj b/modules/eacl/build.clj new file mode 100644 index 000000000..c158dc589 --- /dev/null +++ b/modules/eacl/build.clj @@ -0,0 +1,32 @@ +(ns build + (:require [clojure.tools.build.api :as b])) + +(def module-dir "modules/eacl") +(def lib 'cloudafrica/eacl) +(def version "0.0.1-SNAPSHOT") +(def class-dir (str module-dir "/target/classes")) +(def jar-file (format "%s/target/%s-%s.jar" module-dir (name lib) version)) + +(defn clean [_] + (b/delete {:path (str module-dir "/target")})) + +(defn jar [_] + (clean nil) + (b/write-pom {:class-dir class-dir + :lib lib + :version version + :basis (b/create-basis {:project (str module-dir "/deps.edn")}) + :src-dirs [(str module-dir "/src")]}) + (b/copy-dir {:src-dirs [(str module-dir "/src") + (str module-dir "/resources")] + :target-dir class-dir}) + (b/jar {:class-dir class-dir + :jar-file jar-file})) + +(defn install [_] + (jar nil) + (b/install {:class-dir class-dir + :jar-file jar-file + :lib lib + :version version + :basis (b/create-basis {:project (str module-dir "/deps.edn")})})) diff --git a/modules/eacl/deps.edn b/modules/eacl/deps.edn new file mode 100644 index 000000000..c38d0849d --- /dev/null +++ b/modules/eacl/deps.edn @@ -0,0 +1,12 @@ +{:paths ["src" "resources"] + :deps {org.clojure/clojure {:mvn/version "1.12.0-alpha5"} + com.rpl/specter {:mvn/version "1.1.4"} + metosin/malli {:mvn/version "0.19.1"} + org.clojure/core.cache {:mvn/version "1.1.234"} + instaparse/instaparse {:mvn/version "1.5.0"} + org.clojure/tools.logging {:mvn/version "1.3.0"}} + :aliases {:test {:extra-paths ["test"] + :extra-deps {io.github.cognitect-labs/test-runner {:git/tag "v0.5.1" :git/sha "dfb30dd"}}} + :nrepl {:extra-paths ["test"] + :extra-deps {nrepl/nrepl {:mvn/version "1.3.1"}} + :main-opts ["-m" "nrepl.cmdline"]}}} diff --git a/modules/eacl/src/eacl/backend/spi.cljc b/modules/eacl/src/eacl/backend/spi.cljc new file mode 100644 index 000000000..fb089bb7e --- /dev/null +++ b/modules/eacl/src/eacl/backend/spi.cljc @@ -0,0 +1,19 @@ +(ns eacl.backend.spi) + +(defn cache-stamp [backend] + ((:cache-stamp backend))) + +(defn relation-defs [backend resource-type relation-name] + ((:relation-defs backend) resource-type relation-name)) + +(defn permission-defs [backend resource-type permission-name] + ((:permission-defs backend) resource-type permission-name)) + +(defn subject->resources [backend subject-type subject-id relation-id resource-type cursor-resource-id] + ((:subject->resources backend) subject-type subject-id relation-id resource-type cursor-resource-id)) + +(defn resource->subjects [backend resource-type resource-id relation-id subject-type cursor-subject-id] + ((:resource->subjects backend) resource-type resource-id relation-id subject-type cursor-subject-id)) + +(defn direct-match? [backend subject-type subject-id relation-id resource-type resource-id] + ((:direct-match? backend) subject-type subject-id relation-id resource-type resource-id)) diff --git a/modules/eacl/src/eacl/core.cljc b/modules/eacl/src/eacl/core.cljc new file mode 100644 index 000000000..6456fffd7 --- /dev/null +++ b/modules/eacl/src/eacl/core.cljc @@ -0,0 +1,99 @@ +(ns eacl.core + "Defines the IAuthorization protocol, records & helpers.") + +(defprotocol IAuthorization + ;; For order-dependent calls, we try to maintain the order of [subject permission resource]. + + ;; Check Permissions + ;; We support various arities for convenience. + (can? + [this subject permission resource] + [this subject permission resource consistency] + [this {:as demand :keys [subject permission resource consistency]}]) + + ;; `can?` Example: + ; + ; (can? client (->user "andre") :view (->server 456)) + ; => true | false + ; + ; Records used liberally to avoid typos in subject/object types. + ; Accepts any map-like with {:keys [type id]}. + + ;; Schema + (read-schema [this]) + (write-schema! [this schema]) + + ;; Relationships + (read-relationships [this query]) + ; where query is a map with the following keys (defprotocol does not support multiple :namespaced/keys): + ; {:as query + ; :keys [limit cursor] + ; :subject/keys [type id relation] + ; :resource/keys [type id id-prefix relation]} + ; + ; one of :resource/type, :subject/type or :resource/relation is required. + ; + ; :subject/relation is not supported by EACL. (future: when filtering by :subject/relation, subject schema must have the given relation.) + + (write-relationships! [this updates]) + ; updates is a seq of RelationshipUpdate maps with {:keys [operation relationship]}, where + ; operation is one of #{:create :touch :delete :unspecified} and Relationship has {:keys [subject relation resource]}. + ; Note :touch is like :create but does not throw if a relationship already exists. + + (write-relationship! + [this operation subject relation resource] + [this {:as demand :keys [operation subject relation resource]}]) + + (create-relationships! [this relationships]) + ; create-relationships! takes a seq of Relationship. Construct via ->Relationship, or use vector. + + (create-relationship! + [this subject relation resource] + [this {:as relationship :keys [subject relation resource]}]) + + ; delete-relationships! takes the result of read-relationships, or + ; construct a seq using ->Relationship. + (delete-relationships! [this relationships]) + + (delete-relationship! + [this subject relation resource] + [this {:as relationship :keys [subject relation resource]}]) + + ;; Subject & Resource & Enumeration + (lookup-resources [this {:as query :keys [consistency]}]) + ; lookup-resources (formerly 'what-can?') accepts: + ; - :resource/type – keyword, required. + ; - :permission - keyword, required. + ; - :subject has {:keys [type id]}. Required. + ; - limit - optional number. + ; - offset - optional number. + + (count-resources [this {:as query :keys [consistency]}]) + ; counting can be slow because it enumerates lookup-resources from cursor + + (lookup-subjects [this {:as query :keys [consistency]}]) + ; lookup-subjects (formerly 'who-can?') accepts: + ; - :resource has {:keys [type id]}. Required. + ; - :permission (keyword) required. + ; - :subject/type (keyword) required. + ; - :subject/relation (keyword) optional, e.g. :member. + + (count-subjects [this {:as query :keys [consistency]}]) + ; count-subjects mirrors lookup-subjects pagination semantics but only returns + ; {:count n :limit limit :cursor cursor}. + + (expand-permission-tree [this {:as query :keys [resource permission consistency]}])) + +; Spice affordances from previous impl. +(defrecord Relationship [subject relation resource]) +(defrecord RelationshipUpdate [operation relationship]) + +; Todo: move SpiceObject out of core impl to Spice-specific namespace. + +(defrecord SpiceObject [type id relation]) ; where relation means subject_relation, which is distinct from Relationship.relation + +(defn spice-object + "Multi-arity helper for SubjectReference. + Need a better name for this. Only used internally here." + ([type id] (->SpiceObject type id nil)) + ([type id relation] (->SpiceObject type id relation))) diff --git a/modules/eacl/src/eacl/cursor.cljc b/modules/eacl/src/eacl/cursor.cljc new file mode 100644 index 000000000..3d6566247 --- /dev/null +++ b/modules/eacl/src/eacl/cursor.cljc @@ -0,0 +1,48 @@ +(ns eacl.cursor + (:require [clojure.edn :as edn])) + +(defn- now-seconds [] + (quot (#?(:clj System/currentTimeMillis + :cljs js/Date.now)) + 1000)) + +(defn- encode-string [value] + #?(:clj (.encodeToString + (java.util.Base64/getEncoder) + (.getBytes value "UTF-8")) + :cljs (if-let [btoa (.-btoa js/globalThis)] + (.call btoa js/globalThis value) + (.toString (.from js/Buffer value "utf8") "base64")))) + +(defn- decode-string [value] + #?(:clj (String. (.decode (java.util.Base64/getDecoder) + (.getBytes value "UTF-8")) + "UTF-8") + :cljs (if-let [atob (.-atob js/globalThis)] + (.call atob js/globalThis value) + (.toString (.from js/Buffer value "base64") "utf8")))) + +(defn cursor->token + "Serializes an internal cursor map to an opaque string token with TTL." + [cursor & [{:keys [ttl-seconds] :or {ttl-seconds 300}}]] + (when cursor + (let [with-expiry (assoc cursor :t (+ (now-seconds) ttl-seconds))] + (str "eacl1_" (encode-string (pr-str with-expiry)))))) + +(defn token->cursor + "Deserializes an opaque cursor token. Raw cursor maps are accepted for + backward compatibility." + [token-or-cursor] + (cond + (nil? token-or-cursor) nil + (map? token-or-cursor) token-or-cursor + (and (string? token-or-cursor) + (.startsWith ^String token-or-cursor "eacl1_")) + (try + (let [cursor (edn/read-string (decode-string (subs token-or-cursor 6))) + now (now-seconds)] + (when (> (:t cursor now) now) + (dissoc cursor :t))) + (catch #?(:clj Exception :cljs :default) _ + nil)) + :else nil)) diff --git a/modules/eacl/src/eacl/engine/indexed.cljc b/modules/eacl/src/eacl/engine/indexed.cljc new file mode 100644 index 000000000..878544378 --- /dev/null +++ b/modules/eacl/src/eacl/engine/indexed.cljc @@ -0,0 +1,471 @@ +(ns eacl.engine.indexed + (:require [eacl.backend.spi :as spi] + [eacl.core :refer [spice-object]] + [eacl.lazy-merge-sort :as lazy-sort] + #?@(:clj [[clojure.tools.logging :as log]]))) + +(defn- warn + [message data] + #?(:clj + (log/warn message data) + :cljs + (.warn js/console (str message " " (pr-str data))))) + +(defn inclusive-cursor->exclusive + [cursor-id] + (when cursor-id + (dec cursor-id))) + +(defn permission-paths-cache-key + [backend resource-type permission-name] + [(spi/cache-stamp backend) resource-type permission-name]) + +(defn evict-permission-paths-cache! + [cache-atom] + (reset! cache-atom {})) + +(defn get-permission-paths + [cache-atom calc-permission-paths-fn backend resource-type permission-name] + (let [cache-key (permission-paths-cache-key backend resource-type permission-name)] + (if-let [cached (get @cache-atom cache-key)] + cached + (let [paths (calc-permission-paths-fn backend resource-type permission-name)] + (swap! cache-atom + (fn [cache] + (let [updated (assoc cache cache-key paths)] + (if (> (count updated) 1000) + {cache-key paths} + updated)))) + paths)))) + +(defn resolve-self-relation + [backend resource-type target-relation-name] + (let [defs (spi/relation-defs backend resource-type target-relation-name)] + (if (seq defs) + (mapv (fn [{:keys [relation-id subject-type]}] + {:type :relation + :name target-relation-name + :subject-type subject-type + :relation-id relation-id}) + defs) + (do + (warn "Missing Relation definition" + {:resource-type resource-type + :relation-name target-relation-name}) + [])))) + +(defn calc-permission-paths + ([backend resource-type permission-name] + (calc-permission-paths backend resource-type permission-name #{})) + ([backend resource-type permission-name visited-perms] + (let [perm-defs (spi/permission-defs backend resource-type permission-name) + perm-ids (map :permission-id perm-defs) + updated-visited (reduce conj visited-perms perm-ids)] + (->> perm-defs + (mapcat + (fn [{:keys [permission-id + source-relation-name + target-type + target-name]}] + (cond + (contains? visited-perms permission-id) + (do + (warn "Cycle detected in permission graph" + {:permission-id permission-id + :visited visited-perms}) + []) + + (= :self source-relation-name) + (case target-type + :relation (resolve-self-relation backend resource-type target-name) + :permission [{:type :self-permission + :target-permission target-name + :resource-type resource-type + :permission-id permission-id}] + []) + + :else + (let [via-defs (spi/relation-defs backend resource-type source-relation-name)] + (if (seq via-defs) + (mapcat + (fn [{:keys [relation-id subject-type]}] + (let [intermediate-type subject-type + sub-paths (if (= target-type :permission) + (calc-permission-paths backend intermediate-type target-name updated-visited) + (let [target-defs (spi/relation-defs backend intermediate-type target-name)] + (if (seq target-defs) + (mapv (fn [{:keys [relation-id subject-type]}] + {:type :relation + :name target-name + :subject-type subject-type + :relation-id relation-id}) + target-defs) + (do + (warn "Missing target relation definition" + {:intermediate-type intermediate-type + :target-relation-name target-name}) + []))))] + (if (seq sub-paths) + [{:type :arrow + :via source-relation-name + :target-type intermediate-type + :via-relation-id relation-id + :target-permission (when (= target-type :permission) target-name) + :target-relation (when (= target-type :relation) target-name) + :sub-paths sub-paths}] + []))) + via-defs) + (do + (warn "Missing source relation definition" + {:resource-type resource-type + :via-relation-name source-relation-name}) + [])))))) + vec)))) + +(defn extract-cursor-id + [cursor v1-key] + (if (= 2 (:v cursor)) + (:e cursor) + (get-in cursor [v1-key :id]))) + +(defn arrow-via-intermediates + [intermediate-ids result-fn] + (let [pairs (keep (fn [intermediate-id] + (let [results (result-fn intermediate-id)] + (when (seq results) + {:intermediate-id intermediate-id + :results results}))) + intermediate-ids) + min-intermediate (:intermediate-id (first pairs)) + result-seqs (map :results pairs)] + {:results (if (seq result-seqs) + (lazy-sort/lazy-fold2-merge-dedupe-sorted-by identity result-seqs) + []) + :!state (when min-intermediate (volatile! min-intermediate))})) + +(defn build-v2-cursor + [cursor last-id path-results v1-key] + {:v 2 + :e (or last-id (:e cursor) (get-in cursor [v1-key :id])) + :p (into (or (:p cursor) {}) + (keep (fn [{:keys [idx !state]}] + (when-let [v (and !state @!state)] + [idx v]))) + path-results)}) + +(defn matching-relation-sub-paths + [sub-paths subject-type] + (filter #(and (= :relation (:type %)) + (= subject-type (:subject-type %))) + sub-paths)) + +(declare traverse-permission-path) + +(defn traverse-permission-path-via-subject + [backend get-permission-paths-fn subject-type subject-id path resource-type cursor-id intermediate-cursor-id visited-paths] + (case (:type path) + :relation + {:results (when (= subject-type (:subject-type path)) + (spi/subject->resources backend + subject-type + subject-id + (:relation-id path) + resource-type + cursor-id)) + :!state nil} + + :self-permission + {:results (traverse-permission-path backend + get-permission-paths-fn + subject-type + subject-id + (:target-permission path) + resource-type + cursor-id + (or visited-paths #{})) + :!state nil} + + :arrow + (let [intermediate-type (:target-type path) + via-relation-id (:via-relation-id path) + inclusive-intermediate-cursor (inclusive-cursor->exclusive intermediate-cursor-id)] + (if (:target-relation path) + (let [intermediate-seqs + (->> (matching-relation-sub-paths (:sub-paths path) subject-type) + (map (fn [sub-path] + (spi/subject->resources backend + subject-type + subject-id + (:relation-id sub-path) + intermediate-type + inclusive-intermediate-cursor))) + (filter seq)) + intermediate-ids (if (seq intermediate-seqs) + (lazy-sort/lazy-fold2-merge-dedupe-sorted-by identity intermediate-seqs) + [])] + (arrow-via-intermediates intermediate-ids + (fn [intermediate-id] + (spi/subject->resources backend + intermediate-type + intermediate-id + via-relation-id + resource-type + cursor-id)))) + (let [target-permission (:target-permission path) + intermediate-ids (traverse-permission-path backend + get-permission-paths-fn + subject-type + subject-id + target-permission + intermediate-type + inclusive-intermediate-cursor + (or visited-paths #{}))] + (arrow-via-intermediates intermediate-ids + (fn [intermediate-id] + (spi/subject->resources backend + intermediate-type + intermediate-id + via-relation-id + resource-type + cursor-id)))))))) + +(defn traverse-permission-path + ([backend get-permission-paths-fn subject-type subject-id permission-name resource-type cursor-id] + (traverse-permission-path backend get-permission-paths-fn subject-type subject-id permission-name resource-type cursor-id #{})) + ([backend get-permission-paths-fn subject-type subject-id permission-name resource-type cursor-id visited-paths] + (let [path-key [subject-type subject-id permission-name resource-type]] + (if (contains? visited-paths path-key) + [] + (let [paths (get-permission-paths-fn backend resource-type permission-name) + next-visited (conj visited-paths path-key) + path-seqs (->> paths + (map (fn [path] + (:results + (traverse-permission-path-via-subject backend + get-permission-paths-fn + subject-type + subject-id + path + resource-type + cursor-id + nil + next-visited)))) + (filter seq))] + (if (seq path-seqs) + (lazy-sort/lazy-fold2-merge-dedupe-sorted-by identity path-seqs) + [])))))) + +(defn traverse-permission-path-reverse + [backend get-permission-paths-fn resource-type resource-id path subject-type cursor-id intermediate-cursor-id visited-paths] + (case (:type path) + :relation + {:results (when (= subject-type (:subject-type path)) + (spi/resource->subjects backend + resource-type + resource-id + (:relation-id path) + subject-type + cursor-id)) + :!state nil} + + :self-permission + {:results (let [target-paths (get-permission-paths-fn backend resource-type (:target-permission path)) + path-seqs (->> target-paths + (map (fn [target-path] + (:results + (traverse-permission-path-reverse backend + get-permission-paths-fn + resource-type + resource-id + target-path + subject-type + cursor-id + nil + (or visited-paths #{}))))) + (filter seq))] + (if (seq path-seqs) + (lazy-sort/lazy-fold2-merge-dedupe-sorted-by identity path-seqs) + [])) + :!state nil} + + :arrow + (let [intermediate-type (:target-type path) + via-relation-id (:via-relation-id path) + inclusive-intermediate-cursor (inclusive-cursor->exclusive intermediate-cursor-id) + intermediate-ids (spi/resource->subjects backend + resource-type + resource-id + via-relation-id + intermediate-type + inclusive-intermediate-cursor)] + (if (:target-relation path) + (let [matching-sub-paths (matching-relation-sub-paths (:sub-paths path) subject-type)] + (arrow-via-intermediates intermediate-ids + (fn [intermediate-id] + (let [subject-seqs (->> matching-sub-paths + (map (fn [sub-path] + (spi/resource->subjects backend + intermediate-type + intermediate-id + (:relation-id sub-path) + subject-type + cursor-id))) + (filter seq))] + (if (seq subject-seqs) + (lazy-sort/lazy-fold2-merge-dedupe-sorted-by identity subject-seqs) + []))))) + (let [target-permission (:target-permission path)] + (arrow-via-intermediates intermediate-ids + (fn [intermediate-id] + (let [paths (get-permission-paths-fn backend intermediate-type target-permission) + subject-seqs (->> paths + (map (fn [sub-path] + (:results + (traverse-permission-path-reverse backend + get-permission-paths-fn + intermediate-type + intermediate-id + sub-path + subject-type + cursor-id + nil + (or visited-paths #{}))))) + (filter seq))] + (if (seq subject-seqs) + (lazy-sort/lazy-fold2-merge-dedupe-sorted-by identity subject-seqs) + []))))))))) + +(defn can? + [backend get-permission-paths-fn subject permission resource] + (let [subject-type (:type subject) + subject-id (:id subject) + resource-type (:type resource) + resource-id (:id resource) + paths (get-permission-paths-fn backend resource-type permission)] + (if (or (nil? subject-id) (nil? resource-id)) + false + (boolean + (some + (fn [path] + (case (:type path) + :relation + (when (= subject-type (:subject-type path)) + (spi/direct-match? backend + subject-type + subject-id + (:relation-id path) + resource-type + resource-id)) + + :self-permission + (can? backend get-permission-paths-fn subject (:target-permission path) resource) + + :arrow + (let [intermediate-type (:target-type path) + via-relation-id (:via-relation-id path) + intermediate-ids (spi/resource->subjects backend + resource-type + resource-id + via-relation-id + intermediate-type + nil)] + (if (:target-relation path) + (let [matching-sub-paths (matching-relation-sub-paths (:sub-paths path) subject-type)] + (some (fn [intermediate-id] + (some (fn [sub-path] + (spi/direct-match? backend + subject-type + subject-id + (:relation-id sub-path) + intermediate-type + intermediate-id)) + matching-sub-paths)) + intermediate-ids)) + (some (fn [intermediate-id] + (can? backend + get-permission-paths-fn + subject + (:target-permission path) + (spice-object intermediate-type intermediate-id))) + intermediate-ids))))) + paths))))) + +(def forward-direction + {:anchor-key :subject + :perm-type-fn (fn [query] (:resource/type query)) + :result-type-fn (fn [query] (:resource/type query)) + :traverse-fn traverse-permission-path-via-subject + :v1-cursor-key :resource}) + +(def reverse-direction + {:anchor-key :resource + :perm-type-fn (fn [query] (:type (:resource query))) + :result-type-fn (fn [query] (:subject/type query)) + :traverse-fn traverse-permission-path-reverse + :v1-cursor-key :subject}) + +(defn lazy-merged-lookup + [backend direction get-permission-paths-fn query] + (let [{:keys [anchor-key traverse-fn v1-cursor-key perm-type-fn]} direction + anchor (get query anchor-key) + anchor-type (:type anchor) + anchor-id (:id anchor) + cursor (:cursor query) + cursor-id (extract-cursor-id cursor v1-cursor-key) + permission (:permission query) + perm-type (perm-type-fn query) + result-type-key (if (= anchor-key :subject) :resource/type :subject/type) + result-type (get query result-type-key) + paths (get-permission-paths-fn backend perm-type permission) + path-results (vec + (->> paths + (map-indexed + (fn [idx path] + (let [intermediate-cursor-id (get-in cursor [:p idx]) + {:keys [results !state]} + (if anchor-id + (traverse-fn backend + get-permission-paths-fn + anchor-type + anchor-id + path + result-type + cursor-id + intermediate-cursor-id + #{}) + {:results [] :!state nil})] + {:idx idx + :results results + :!state !state}))) + (filter (comp seq :results))))] + {:results (if (seq path-results) + (lazy-sort/lazy-fold2-merge-dedupe-sorted-by identity (map :results path-results)) + []) + :path-results path-results})) + +(defn lookup + [backend direction get-permission-paths-fn query] + (let [{:keys [result-type-fn v1-cursor-key]} direction + {:keys [limit cursor] :or {limit 1000}} query + {:keys [results path-results]} (lazy-merged-lookup backend direction get-permission-paths-fn query) + limited-results (if (>= limit 0) + (take limit results) + results) + result-type (result-type-fn query) + items (doall (map #(spice-object result-type %) limited-results)) + last-id (:id (last items))] + {:data items + :cursor (build-v2-cursor cursor last-id path-results v1-cursor-key)})) + +(defn count-results + [backend direction get-permission-paths-fn query default-v1-key] + (let [{:keys [limit cursor] :or {limit -1}} query + {:keys [results path-results]} (lazy-merged-lookup backend direction get-permission-paths-fn query) + limited-results (if (>= limit 0) + (take limit results) + results) + counted (doall limited-results) + last-id (last counted)] + {:count (count counted) + :limit limit + :cursor (build-v2-cursor cursor last-id path-results default-v1-key)})) diff --git a/modules/eacl/src/eacl/impl/spicedb.clj b/modules/eacl/src/eacl/impl/spicedb.clj new file mode 100644 index 000000000..79e60e5ae --- /dev/null +++ b/modules/eacl/src/eacl/impl/spicedb.clj @@ -0,0 +1,5 @@ +(ns eacl.impl.spicedb + (:require [eacl.core :as proto])) + +; todo: transfer SpiceDB gRPC Clojure implementation from closed-source. +; this impl. also satisfies the `IAuthorization` protocol in eacl.protocols. \ No newline at end of file diff --git a/modules/eacl/src/eacl/lazy_merge_sort.cljc b/modules/eacl/src/eacl/lazy_merge_sort.cljc new file mode 100644 index 000000000..1a5709e66 --- /dev/null +++ b/modules/eacl/src/eacl/lazy_merge_sort.cljc @@ -0,0 +1,138 @@ +(ns eacl.lazy-merge-sort + "Optimized lazy merge-sort with deduplication for sorted sequences. + + Primary entry point: `lazy-fold2-merge-dedupe-sorted-by`. + + Legacy helper names remain as wrappers for compatibility with older tests.") + +(def ^:private min-sentinel + #?(:clj Long/MIN_VALUE + :cljs js/Number.MIN_SAFE_INTEGER)) + +(defn- lazy-merge2-dedupe-longs + ([x y] (lazy-merge2-dedupe-longs min-sentinel x y)) + ([last-key x y] + (lazy-seq + (let [sx (seq x) + sy (seq y)] + (cond + (nil? sx) + (when sy + (if (= last-key min-sentinel) + sy + (drop-while #(= % last-key) y))) + + (nil? sy) + (if (= last-key min-sentinel) + sx + (drop-while #(= % last-key) x)) + + :else + (let [xf (first sx) + yf (first sy)] + (cond + (= xf yf) + (if (= xf last-key) + (lazy-merge2-dedupe-longs last-key (rest x) (rest y)) + (cons (first sx) + (lazy-merge2-dedupe-longs xf (rest x) (rest y)))) + + (< xf yf) + (if (= xf last-key) + (lazy-merge2-dedupe-longs last-key (rest x) y) + (cons (first sx) + (lazy-merge2-dedupe-longs xf (rest x) y))) + + :else + (if (= yf last-key) + (lazy-merge2-dedupe-longs last-key x (rest y)) + (cons (first sy) + (lazy-merge2-dedupe-longs yf x (rest y))))))))))) + +(defn- fold2-merge-dedupe-longs + [seqs] + (let [non-empty (vec (filter seq seqs))] + (case (count non-empty) + 0 () + 1 (first non-empty) + 2 (lazy-merge2-dedupe-longs (first non-empty) (second non-empty)) + (recur + (mapv (fn [pair] + (if (next pair) + (lazy-merge2-dedupe-longs (first pair) (second pair)) + (first pair))) + (partition-all 2 non-empty)))))) + +(defn- lazy-merge2-dedupe-by + ([keyfn key-cmp x y] + (lazy-merge2-dedupe-by keyfn key-cmp nil x y)) + ([keyfn key-cmp last-key x y] + (lazy-seq + (let [sx (seq x) + sy (seq y)] + (cond + (nil? sx) + (when sy + (if (nil? last-key) + sy + (drop-while #(= (keyfn %) last-key) y))) + + (nil? sy) + (if (nil? last-key) + sx + (drop-while #(= (keyfn %) last-key) x)) + + :else + (let [xf (first sx) + yf (first sy) + xk (keyfn xf) + yk (keyfn yf)] + (cond + (= xk yk) + (if (= xk last-key) + (lazy-merge2-dedupe-by keyfn key-cmp last-key (rest x) (rest y)) + (cons xf + (lazy-merge2-dedupe-by keyfn key-cmp xk (rest x) (rest y)))) + + (key-cmp xk yk) + (if (= xk last-key) + (lazy-merge2-dedupe-by keyfn key-cmp last-key (rest x) y) + (cons xf + (lazy-merge2-dedupe-by keyfn key-cmp xk (rest x) y))) + + :else + (if (= yk last-key) + (lazy-merge2-dedupe-by keyfn key-cmp last-key x (rest y)) + (cons yf + (lazy-merge2-dedupe-by keyfn key-cmp yk x (rest y))))))))))) + +(defn- fold2-merge-dedupe-generic + [keyfn seqs] + (let [key-cmp (fn [a b] (< (compare a b) 0)) + merge2 (fn [x y] (lazy-merge2-dedupe-by keyfn key-cmp x y)) + non-empty (vec (filter seq seqs))] + (case (count non-empty) + 0 () + 1 (first non-empty) + 2 (merge2 (first non-empty) (second non-empty)) + (recur + keyfn + (mapv (fn [pair] + (if (next pair) + (merge2 (first pair) (second pair)) + (first pair))) + (partition-all 2 non-empty)))))) + +(defn lazy-fold2-merge-dedupe-sorted-by + [keyfn seqs] + (if (identical? keyfn identity) + (fold2-merge-dedupe-longs seqs) + (fold2-merge-dedupe-generic keyfn seqs))) + +(defn lazy-merge-dedupe-sort + [seqs] + (lazy-fold2-merge-dedupe-sorted-by identity seqs)) + +(defn lazy-merge-dedupe-sort-by + [keyfn seqs] + (lazy-fold2-merge-dedupe-sorted-by keyfn seqs)) diff --git a/modules/eacl/src/eacl/schema/model.cljc b/modules/eacl/src/eacl/schema/model.cljc new file mode 100644 index 000000000..d246530ef --- /dev/null +++ b/modules/eacl/src/eacl/schema/model.cljc @@ -0,0 +1,156 @@ +(ns eacl.schema.model + (:require [clojure.set :as set])) + +(defn ->relation-id + "Uses (str kw) instead of (name kw) to retain namespaces. Leading colons are expected." + [resource-type relation-name subject-type] + (str "eacl.relation:" resource-type ":" relation-name ":" subject-type)) + +(defn Relation + "Defines a logical EACL relation." + ([resource-type relation-name subject-type] + {:pre [(keyword? resource-type) + (keyword? relation-name) + (keyword? subject-type) + (not= resource-type :self) + (not= relation-name :self)]} + {:eacl/id (->relation-id resource-type relation-name subject-type) + :eacl.relation/resource-type resource-type + :eacl.relation/relation-name relation-name + :eacl.relation/subject-type subject-type}) + ([resource-type+relation-name subject-type] + {:pre [(keyword? resource-type+relation-name) + (namespace resource-type+relation-name) + (keyword? subject-type)]} + (Relation (keyword (namespace resource-type+relation-name)) + (keyword (name resource-type+relation-name)) + subject-type))) + +(defn ->permission-id + "Uses (str kw) instead of (name kw) to retain namespaces. Leading colons are expected." + [resource-type permission-name arrow target-type relation-or-permission] + (str "eacl:permission:" resource-type ":" permission-name ":" arrow ":" target-type ":" relation-or-permission)) + +(defn Permission + "Defines a logical EACL permission." + [resource-type permission-name + {:as spec + :keys [arrow relation permission] + :or {arrow :self}}] + {:pre [(keyword? resource-type) + (keyword? permission-name) + (map? spec) + (or relation permission) + (not (and relation permission))]} + (cond + relation + {:eacl/id (->permission-id resource-type permission-name arrow :relation relation) + :eacl.permission/resource-type resource-type + :eacl.permission/permission-name permission-name + :eacl.permission/source-relation-name arrow + :eacl.permission/target-type :relation + :eacl.permission/target-name relation} + + permission + {:eacl/id (->permission-id resource-type permission-name arrow :permission permission) + :eacl.permission/resource-type resource-type + :eacl.permission/permission-name permission-name + :eacl.permission/source-relation-name arrow + :eacl.permission/target-type :permission + :eacl.permission/target-name permission} + + :else + (throw (ex-info "Invalid Permission spec. Expected one of {:relation name}, {:permission name}, {:arrow source :permission target} or {:arrow source :relation target}" + {:spec spec})))) + +(defn validate-schema-references + "Validates that all permission references are valid. + Returns nil if valid, throws ex-info with :errors vector if invalid." + [{:keys [relations permissions]}] + (let [relations-by-type (group-by :eacl.relation/resource-type relations) + permissions-by-type (group-by :eacl.permission/resource-type permissions) + relation-names-by-type (into {} + (for [[rt rels] relations-by-type] + [rt (set (map :eacl.relation/relation-name rels))])) + permission-names-by-type (into {} + (for [[rt perms] permissions-by-type] + [rt (set (map :eacl.permission/permission-name perms))])) + relation-subject-types (into {} + (for [rel relations] + [[(:eacl.relation/resource-type rel) + (:eacl.relation/relation-name rel)] + (:eacl.relation/subject-type rel)])) + errors (atom [])] + (doseq [perm permissions] + (let [res-type (:eacl.permission/resource-type perm) + perm-name (:eacl.permission/permission-name perm) + source-rel (:eacl.permission/source-relation-name perm) + target-type (:eacl.permission/target-type perm) + target-name (:eacl.permission/target-name perm)] + (if (= source-rel :self) + (if (= target-type :relation) + (when-not (contains? (get relation-names-by-type res-type) target-name) + (swap! errors conj + {:type :invalid-self-relation + :permission (str (name res-type) "/" (name perm-name)) + :target target-name + :message (str "Permission " (name res-type) "/" (name perm-name) + " references non-existent relation: " (name target-name))})) + (when-not (contains? (get permission-names-by-type res-type) target-name) + (swap! errors conj + {:type :invalid-self-permission + :permission (str (name res-type) "/" (name perm-name)) + :target target-name + :message (str "Permission " (name res-type) "/" (name perm-name) + " references non-existent permission: " (name target-name))}))) + (do + (when-not (contains? (get relation-names-by-type res-type) source-rel) + (swap! errors conj + {:type :missing-source-relation + :permission (str (name res-type) "/" (name perm-name)) + :relation source-rel + :message (str "Permission " (name res-type) "/" (name perm-name) + " references non-existent relation: " (name source-rel))})) + (when (contains? (get relation-names-by-type res-type) source-rel) + (let [target-res-type (get relation-subject-types [res-type source-rel])] + (when target-res-type + (if (= target-type :relation) + (when-not (contains? (get relation-names-by-type target-res-type) target-name) + (swap! errors conj + {:type :invalid-arrow-target-relation + :permission (str (name res-type) "/" (name perm-name)) + :arrow-via source-rel + :target-type target-res-type + :target target-name + :message (str "Permission " (name res-type) "/" (name perm-name) + " arrow via " (name source-rel) "->" (name target-name) + " - relation '" (name target-name) "' does not exist on " (name target-res-type))})) + (when-not (contains? (get permission-names-by-type target-res-type) target-name) + (swap! errors conj + {:type :invalid-arrow-target-permission + :permission (str (name res-type) "/" (name perm-name)) + :arrow-via source-rel + :target-type target-res-type + :target target-name + :message (str "Permission " (name res-type) "/" (name perm-name) + " arrow via " (name source-rel) "->" (name target-name) + " - permission '" (name target-name) "' does not exist on " (name target-res-type))})))))))))) + (when (seq @errors) + (throw (ex-info "Invalid schema: reference validation failed" + {:errors @errors + :error-count (count @errors)}))) + nil)) + +(defn calc-set-deltas [before after] + {:additions (set/difference after before) + :unchanged (set/intersection before after) + :retractions (set/difference before after)}) + +(defn compare-schema + "Compares before & after schema (without DB IDs) and returns set deltas." + [{before-relations :relations + before-permissions :permissions} + {after-relations :relations + after-permissions :permissions}] + {:relations (calc-set-deltas (set before-relations) (set after-relations)) + :permissions (calc-set-deltas (set before-permissions) (set after-permissions))}) diff --git a/modules/eacl/src/eacl/spicedb/consistency.cljc b/modules/eacl/src/eacl/spicedb/consistency.cljc new file mode 100644 index 000000000..40962fc2d --- /dev/null +++ b/modules/eacl/src/eacl/spicedb/consistency.cljc @@ -0,0 +1,8 @@ +(ns eacl.spicedb.consistency) + +; EACL is always fully-consistent, so these +; are just here to maintain API-level compatibility. +; Impl. should throw if no fully-consistent is passed. +(defn fresh [token] :fresh) +(def minimize-latency :minimize-latency) +(def fully-consistent :fully-consistent) diff --git a/modules/eacl/src/eacl/spicedb/parser.cljc b/modules/eacl/src/eacl/spicedb/parser.cljc new file mode 100644 index 000000000..aba513c63 --- /dev/null +++ b/modules/eacl/src/eacl/spicedb/parser.cljc @@ -0,0 +1,643 @@ +(ns eacl.spicedb.parser + "SpiceDB schema DSL parser for EACL." + (:require [instaparse.core :as insta] + [clojure.string :as str] + [clojure.walk :as walk] + #?(:clj [clojure.pprint :as pprint] + :cljs [cljs.pprint :as pprint]) + [eacl.schema.model :as model])) + +; primary-expr = identifier | <'('> permission-expr <')'> +;; Define the SpiceDB grammar with auto-whitespace +;; Full SpiceDB grammar - parses the complete official syntax. +;; EACL-specific restrictions are enforced during validation, not parsing. +(def spicedb-parser + (insta/parser + "(* Top-level schema *) + schema = definition+ + + (* Definition block *) + definition = <'definition'> type-path <'{'> definition-body <'}'> + definition-body = (relation | permission)* + + (* Type paths support namespacing: docs/document *) + type-path = identifier (<'/'> identifier)* + + (* Relations *) + relation = <'relation'> relation-name <':'> relation-type-expr + relation-name = identifier + + (* Relation type expression: user | group#member | doc:* with caveat *) + relation-type-expr = relation-type-ref (<'|'> relation-type-ref)* + relation-type-ref = type-path relation-modifier? caveat-ref? + relation-modifier = wildcard | subject-relation + wildcard = <':'> <'*'> + subject-relation = <'#'> identifier + caveat-ref = <'with'> identifier + + (* Permissions *) + permission = <'permission'> permission-name <'='> permission-expr + = identifier + + (* Permission expressions with all operators *) + permission-expr = union-expr + union-expr = intersect-expr (<'+'> intersect-expr)* + intersect-expr = exclusion-expr (<'&'> exclusion-expr)* + exclusion-expr = arrow-expr (<'-'> arrow-expr)* + + (* Arrow expressions: rel->perm or rel.any(perm) or rel.all(perm) *) + arrow-expr = arrow-func-expr | simple-arrow-expr + simple-arrow-expr = base-expr (<'->'> base-expr)* + arrow-func-expr = identifier <'.'> arrow-func-name <'('> identifier <')'> + arrow-func-name = 'any' | 'all' + + (* Base expressions *) + base-expr = nil-expr | self-expr | paren-expr | identifier + nil-expr = <'nil'> + self-expr = <'self'> + paren-expr = <'('> permission-expr <')'> + + (* Identifiers - must not match keywords *) + identifier = !('nil' | 'self' | 'definition' | 'relation' | 'permission' | 'with' | 'any' | 'all') #'[a-zA-Z_][a-zA-Z0-9_]*'" + :auto-whitespace :standard)) + +;; Example SpiceDB schema +(def example-schema + "definition user {} + + definition platform { + relation super_admin: user + } + + definition account { + relation platform: platform + relation owner: user + + permission admin = owner + platform->super_admin + permission view = owner + admin + permission update = admin + }") + +;; Parse the schema +(defn parse-schema [schema-str] + (spicedb-parser schema-str)) + +;; Pretty print parse tree +(defn pretty-print-tree [tree] + (pprint/pprint tree)) + +;; ============================================================================ +;; Parse Tree Extraction Functions (for new full SpiceDB grammar) +;; ============================================================================ + +(defn- extract-identifier + "Extracts the string value from an [:identifier 'name'] node." + [node] + (when (and (vector? node) (= :identifier (first node))) + (second node))) + +(defn- extract-type-path + "Extracts a type path string from [:type-path [:identifier 'a'] [:identifier 'b']] -> 'a/b'" + [node] + (when (and (vector? node) (= :type-path (first node))) + (->> (rest node) + (map extract-identifier) + (str/join "/")))) + +(defn- extract-relation-type-ref + "Extracts a relation type reference with optional modifier and caveat. + Returns {:type 'user', :wildcard? false, :subject-relation nil, :caveat nil}" + [node] + (when (and (vector? node) (= :relation-type-ref (first node))) + (let [children (rest node) + type-path (extract-type-path (first children)) + modifier (some #(when (and (vector? %) (= :relation-modifier (first %))) %) children) + caveat (some #(when (and (vector? %) (= :caveat-ref (first %))) %) children)] + {:type type-path + :wildcard? (boolean (some #(and (vector? %) (= :wildcard (first %))) (rest modifier))) + :subject-relation (when-let [sr (some #(when (and (vector? %) (= :subject-relation (first %))) %) (rest modifier))] + (extract-identifier (second sr))) + :caveat (when caveat (extract-identifier (second caveat)))}))) + +(defn- extract-relation-type-expr + "Extracts all type refs from a relation-type-expr. + Returns vector of type ref maps." + [node] + (when (and (vector? node) (= :relation-type-expr (first node))) + (vec (map extract-relation-type-ref (rest node))))) + +(defn extract-relations + "Extract relations from definition body. + Returns a map where each key is a relation name and value is a vector of type refs." + [definition-body] + (if (and (vector? definition-body) (= :definition-body (first definition-body))) + (->> (rest definition-body) + (filter #(and (vector? %) (= :relation (first %)))) + (map (fn [[_ rel-name-node type-expr-node]] + (let [rel-name (extract-identifier (second rel-name-node)) + type-refs (extract-relation-type-expr type-expr-node)] + [rel-name type-refs]))) + (into {})) + {})) + +(defn extract-permissions + "Extract permissions from definition body. + Returns a vector of {:name 'perm-name', :expression }" + [definition-body] + (if (and (vector? definition-body) (= :definition-body (first definition-body))) + (->> (rest definition-body) + (filter #(and (vector? %) (= :permission (first %)))) + (map (fn [[_ perm-name-node expr]] + {:name (extract-identifier perm-name-node) + :expression expr}))) + [])) + +(defn extract-definitions + "Extract definitions from parse tree. + Returns map of {type-path {:relations {...}, :permissions [...]}}" + [parse-tree] + (->> parse-tree + (filter #(and (vector? %) (= :definition (first %)))) + (map (fn [[_ type-path-node definition-body]] + (let [type-path (extract-type-path type-path-node)] + [type-path + {:relations (extract-relations definition-body) + :permissions (extract-permissions definition-body)}]))) + (into {}))) + +(defn transform-schema + "Transform parse tree to intermediate representation." + [parse-tree] + (when (and (vector? parse-tree) (= :schema (first parse-tree))) + {:definitions (extract-definitions (rest parse-tree))})) + +;; Helper to parse expressions +(defn parse-permission-expression [expr-str] + (let [full-schema (str "definition temp { permission test = " expr-str " }") + parsed (spicedb-parser full-schema)] + (if (insta/failure? parsed) + (do + (println "Failed to parse expression:" expr-str) + (println "Error:" (insta/get-failure parsed)) + nil) + ;; Path: schema -> definition -> definition-body -> permission -> permission-expr + (get-in parsed [1 2 1 2])))) + +;; Transform expressions to a more usable format +(defn transform-expression [expr] + (cond + (vector? expr) + (case (first expr) + :union-expr (let [operands (rest expr)] + (if (= 1 (count operands)) + (transform-expression (first operands)) + {:type :union + :operands (map transform-expression operands)})) + :arrow-expr (let [parts (rest expr)] + (if (= 1 (count parts)) + (transform-expression (first parts)) + {:type :arrow + :base (transform-expression (first parts)) + :path (map #(second %) (rest parts))})) + :primary-expr (transform-expression (second expr)) + :identifier {:type :identifier :name (second expr)} + :permission-expr (let [children (rest expr) + operands (filter #(not= :permission-operator (first %)) children)] + (if (= 1 (count operands)) + (transform-expression (first operands)) + {:type :union + :operands (map transform-expression operands)})) + :direct-permission {:type :identifier :name (second expr)} + :arrow-permission {:type :arrow + :base {:type :identifier :name (second expr)} + :path [(nth expr 2)]} + expr) + :else expr)) + +;; Pretty print expressions in a readable format +(defn format-expression [expr] + (cond + (map? expr) + (case (:type expr) + :union (str "(" (str/join " + " (map format-expression (:operands expr))) ")") + :arrow (str (format-expression (:base expr)) "->" (str/join "->" (:path expr))) + :identifier (:name expr) + (str expr)) + :else (str expr))) + +;; Analyze a specific definition +(defn analyze-definition [schema-str def-name] + (let [parsed (parse-schema schema-str)] + (when-not (insta/failure? parsed) + (let [definitions (extract-definitions (rest parsed)) + target-def (first (filter #(= def-name (:name %)) definitions))] + (when target-def + (println (str "Definition: " def-name)) + (println "Relations:") + (doseq [rel (:relations target-def)] + (println (str " " (:name rel) " : " (:type rel)))) + (println "Permissions:") + (doseq [perm (:permissions target-def)] + (println (str " " (:name perm) " = " + (format-expression (transform-expression (:expression perm)))))) + target-def))))) + +;; Usage examples +(defn demo [] + (println "=== Parsing SpiceDB Schema ===") + + ;; Parse the full schema + (let [parsed (parse-schema example-schema)] + (if (insta/failure? parsed) + (do + (println "Parse failed:") + (println (insta/get-failure parsed))) + (do + (println "\n1. Schema structure:") + (let [transformed (transform-schema parsed)] + (doseq [def (:definitions transformed)] + (println (str "- " (:name def) + " (" (count (:relations def)) " relations, " + (count (:permissions def)) " permissions)")))) + + (println "\n2. Detailed breakdown:") + (doseq [def-name ["user" "platform" "account"]] + (analyze-definition example-schema def-name) + (println))))) + + (rest (get (parse-permission-expression "owner + platform->super_admin") 1)) + + ;; Parse individual expressions + (println "\n=== Parsing Individual Expressions ===") + (doseq [expr ["owner + admin" + "platform->super_admin" + "owner + platform->super_admin" + "account->admin + vpc->admin + shared_admin"]] + (let [parsed-expr (parse-permission-expression expr)] + (if parsed-expr + (do + (println (str "Expression: " expr)) + (println (str "Parsed as: " (format-expression (transform-expression parsed-expr)))) + (println (str "Structure: " (transform-expression parsed-expr))) + (println)) + (println (str "Failed to parse: " expr))))) + + ;; Demonstrate error handling + (println "\n=== Error Handling ===") + (let [bad-schema "definition user { invalid syntax }"] + (let [result (parse-schema bad-schema)] + (if (insta/failure? result) + (println "Parse error (expected):" (insta/get-failure result)) + (println "Unexpected success"))))) + +;; ============================================================================ +;; EACL Validation Functions +;; Validates that parsed SpiceDB schemas conform to EACL restrictions. +;; Parsing accepts full SpiceDB syntax; validation enforces EACL limits. +;; ============================================================================ + +(defn- collect-parse-tree-issues + "Walks parse tree and collects all EACL compatibility issues. + Returns a vector of issue maps with informative error messages." + [parse-tree] + (let [issues (atom [])] + (walk/postwalk + (fn [node] + (when (vector? node) + (case (first node) + ;; Check for intersection operator + :intersect-expr + (when (> (count (rest node)) 1) + (swap! issues conj + {:type :unsupported-operator + :operator "&" + :message "Unsupported operator: Intersection (&). EACL only supports Union (+) at this time."})) + + ;; Check for exclusion operator + :exclusion-expr + (when (> (count (rest node)) 1) + (swap! issues conj + {:type :unsupported-operator + :operator "-" + :message "Unsupported operator: Exclusion (-). EACL only supports Union (+) at this time."})) + + ;; Check for multi-level arrows + :simple-arrow-expr + (when (> (count (filter #(and (vector? %) (= :base-expr (first %))) (rest node))) 2) + (swap! issues conj + {:type :multi-level-arrow + :message "Unsupported feature: Multi-level arrows (e.g., a->b->c). EACL only supports single-level arrows like rel->perm."})) + + ;; Check for .all() function (only .any() is implicitly supported via arrow) + :arrow-func-expr + (let [func-name-node (some #(when (and (vector? %) (= :arrow-func-name (first %))) %) (rest node)) + func-name (second func-name-node)] + (when (= func-name "all") + (swap! issues conj + {:type :unsupported-arrow-function + :function "all" + :message "Unsupported function: .all(). EACL only supports .any() (equivalent to -> arrow). Use rel->perm instead."}))) + + ;; Check for nil expression + :nil-expr + (swap! issues conj + {:type :unsupported-keyword + :keyword "nil" + :message "Unsupported keyword: 'nil'. EACL does not support nil permissions."}) + + ;; Check for self expression (might be supportable in future) + :self-expr + (swap! issues conj + {:type :unsupported-keyword + :keyword "self" + :message "Unsupported keyword: 'self'. EACL does not support self-referencing permissions."}) + + ;; Check for type paths with namespaces + :type-path + (when (> (count (rest node)) 1) + (swap! issues conj + {:type :namespaced-type + :message "Unsupported feature: Namespaced type paths (e.g., docs/document). Use simple type names like 'document'."})) + + ;; Default: no issue for other node types + nil)) + node) + parse-tree) + @issues)) + +(defn- collect-relation-issues + "Check relations for EACL compatibility issues. + Takes the transformed schema definitions map." + [definitions] + (let [issues (atom [])] + (doseq [[res-type {:keys [relations]}] definitions + [rel-name type-refs] relations + type-ref type-refs] + ;; Check for wildcards + (when (:wildcard? type-ref) + (swap! issues conj + {:type :wildcard-relation + :resource-type res-type + :relation rel-name + :message (str "Unsupported feature: Wildcard relation '" (:type type-ref) ":*' in " + res-type "/" rel-name ". EACL does not support public/wildcard access.")})) + + ;; Check for subject relations + (when (:subject-relation type-ref) + (swap! issues conj + {:type :subject-relation + :resource-type res-type + :relation rel-name + :subject-relation (:subject-relation type-ref) + :message (str "Unsupported feature: Subject relation '" (:type type-ref) "#" (:subject-relation type-ref) + "' in " res-type "/" rel-name ". EACL does not support nested subject relations.")})) + + ;; Check for caveats + (when (:caveat type-ref) + (swap! issues conj + {:type :caveat + :resource-type res-type + :relation rel-name + :caveat (:caveat type-ref) + :message (str "Unsupported feature: Caveat 'with " (:caveat type-ref) "' in " + res-type "/" rel-name ". EACL does not support conditional access via caveats.")}))) + @issues)) + +(defn validate-eacl-restrictions + "Validates that a parsed SpiceDB schema conforms to EACL restrictions. + Takes a parse tree and throws ex-info if any unsupported features are found. + + EACL restrictions: + - Only union (+) operator allowed (no intersection &, exclusion -) + - Only single-level arrows (no a->b->c) + - No .all() arrow function (only implicit .any() via arrow) + - No nil keyword + - No self keyword + - No namespaced type paths (docs/document) + - No wildcards (user:*) + - No subject relations (group#member) + - No caveats (with caveatname) + + Returns nil if valid, throws ex-info with :issues vector if invalid." + [parse-tree transformed-schema] + (let [parse-issues (collect-parse-tree-issues parse-tree) + relation-issues (collect-relation-issues (:definitions transformed-schema)) + all-issues (vec (concat parse-issues relation-issues))] + (when (seq all-issues) + (let [first-msg (:message (first all-issues)) + total (count all-issues) + summary (if (= 1 total) + first-msg + (str first-msg " (and " (dec total) " more issue(s))"))] + (throw (ex-info summary + {:issues all-issues + :issue-count total})))) + nil)) + +;; Keep old function for backwards compatibility, but delegate to new validation +(defn validate-operators + "DEPRECATED: Use validate-eacl-restrictions instead. + Kept for backwards compatibility." + [parse-tree] + (let [issues (filter #(= :unsupported-operator (:type %)) + (collect-parse-tree-issues parse-tree))] + (when (seq issues) + (throw (ex-info "Unsupported operator in schema" + {:operators (set (map :operator issues)) + :message (str "EACL only supports union (+) operators. " + "Found unsupported operators. " + "Exclusion (-) and intersection (&) are not supported.")}))))) + +;; ============================================================================ +;; Permission Expression Transformation +;; Converts new grammar parse tree to component list for EACL +;; ============================================================================ + +(defn- extract-base-expr-identifier + "Extract identifier string from a base-expr node." + [node] + (when (and (vector? node) (= :base-expr (first node))) + (let [child (second node)] + (when (and (vector? child) (= :identifier (first child))) + (second child))))) + +(defn- transform-arrow-expr + "Transform an arrow expression to component maps. + Returns vector of {:type :identifier/:arrow, ...} maps." + [node] + (cond + ;; Arrow function expression: rel.any(perm) or rel.all(perm) + (and (vector? node) (= :arrow-func-expr (first node))) + (let [children (rest node) + base-id (extract-identifier (first children)) + func-node (some #(when (and (vector? %) (= :arrow-func-name (first %))) %) children) + func-name (second func-node) + target-id (extract-identifier (last children))] + ;; .any() is equivalent to arrow, .all() should have been rejected by validation + [{:type :arrow :base {:type :identifier :name base-id} :path [target-id]}]) + + ;; Simple arrow expression: rel->perm or rel->perm->perm2 + (and (vector? node) (= :simple-arrow-expr (first node))) + (let [base-exprs (filter #(and (vector? %) (= :base-expr (first %))) (rest node)) + ids (map extract-base-expr-identifier base-exprs)] + (if (= 1 (count ids)) + ;; Single identifier - direct permission/relation reference + [{:type :identifier :name (first ids)}] + ;; Arrow expression + [{:type :arrow :base {:type :identifier :name (first ids)} :path (vec (rest ids))}])) + + ;; Wrapped arrow expr + (and (vector? node) (= :arrow-expr (first node))) + (transform-arrow-expr (second node)) + + :else [])) + +(defn- transform-exclusion-expr [node] + "Transform exclusion expression. After validation, this should only have one child." + (when (and (vector? node) (= :exclusion-expr (first node))) + (mapcat transform-arrow-expr (rest node)))) + +(defn- transform-intersect-expr [node] + "Transform intersection expression. After validation, this should only have one child." + (when (and (vector? node) (= :intersect-expr (first node))) + (mapcat transform-exclusion-expr (rest node)))) + +(defn- transform-union-expr [node] + "Transform union expression to flat list of components." + (when (and (vector? node) (= :union-expr (first node))) + (vec (mapcat transform-intersect-expr (rest node))))) + +(defn- flatten-expression + "Flatten a permission expression to a vector of component maps. + Each component is {:type :identifier/:arrow, ...}" + [expr] + (when (and (vector? expr) (= :permission-expr (first expr))) + (transform-union-expr (second expr)))) + +;; ============================================================================ +;; Schema Info Collection +;; ============================================================================ + +(defn- collect-schema-info + "Build lookup tables from transformed schema for arrow resolution." + [definitions] + (reduce-kv + (fn [acc res-type {:keys [relations permissions]}] + (let [;; Get simple type names (first type ref for each relation) + relation-names (set (keys relations)) + ;; Map relation name to target type (first type in list) + relation-types (into {} + (for [[rel-name type-refs] relations + :let [first-ref (first type-refs)] + :when first-ref] + [rel-name (:type first-ref)]))] + (assoc acc res-type + {:relations relation-names + :relation-types relation-types + :relation-all-types relations + :permissions (set (map :name permissions))}))) + {} + definitions)) + +;; ============================================================================ +;; Component Resolution +;; ============================================================================ + +(defn- resolve-component + "Resolve a component map to EACL Permission spec. + component: {:type :identifier/:arrow, :name '...', :base {...}, :path [...]}" + [component resource-type schema-info] + (case (:type component) + :identifier + (let [name (:name component) + info (get schema-info resource-type)] + (if (contains? (:relations info) name) + {:relation (keyword name)} + {:permission (keyword name)})) + + :arrow + (let [base-name (-> component :base :name) + path-elements (:path component) + path (first path-elements) + info (get schema-info resource-type) + target-type (get-in info [:relation-types base-name])] + (if-not target-type + (throw (ex-info (str "Unknown relation for arrow base: " base-name " on " resource-type) + {:component component :resource-type resource-type})) + (let [target-info (get schema-info target-type) + target-is-relation (contains? (:relations target-info) path)] + {:arrow (keyword base-name) + (if target-is-relation :relation :permission) (keyword path)}))) + + (throw (ex-info "Unsupported component type" {:component component})))) + +;; ============================================================================ +;; Main Transformation Function +;; ============================================================================ + +(defn ->eacl-schema + "Convert parsed SpiceDB schema to EACL internal representation. + + Steps: + 1. Transform parse tree to intermediate representation + 2. Validate EACL restrictions (throws on unsupported features) + 3. Convert to EACL Relations and Permissions + + Returns {:relations [...] :permissions [...]}" + [parse-tree] + (let [transformed (transform-schema parse-tree)] + ;; Validate EACL restrictions (parsing allows full SpiceDB, validation enforces limits) + (validate-eacl-restrictions parse-tree transformed) + + (let [definitions (:definitions transformed) + schema-info (collect-schema-info definitions)] + {:relations + (vec + ;; Expand multi-type relations into multiple Relation entities + (for [[res-type {:keys [relations]}] definitions + [rel-name type-refs] relations + type-ref type-refs + :let [subject-type (:type type-ref)]] + (model/Relation (keyword res-type) (keyword rel-name) (keyword subject-type)))) + + :permissions + (vec + (apply concat + (for [[res-type {:keys [permissions]}] definitions + {:keys [name expression]} permissions] + (let [components (flatten-expression expression)] + (for [comp components + :when comp] + (let [spec (resolve-component comp res-type schema-info)] + (model/Permission (keyword res-type) (keyword name) spec)))))))}))) + +(defn extract-expr [permission-exp] + (-> permission-exp + (get 1) + (rest))) + +;; Run the demo +(comment + (def *defs + (let [parse-tree (parse-schema example-schema)] + (:definitions (transform-schema parse-tree)))) + + (doall + (for [[resource-type spec :as definition] *defs] + (do + (prn 'definition definition) + (let [{:keys [relations permissions]} spec] + (concat + (for [{:as relation + relation-name :name + subject-type :type} relations] + (do + (prn 'relation relation) + (model/Relation (keyword resource-type) (keyword relation-name) (keyword subject-type)))) + (for [{:as permission + permission-name :name + expr :expression} permissions] + (extract-expr expr))))))) + + (demo) + (analyze-definition example-schema "account")) diff --git a/modules/eacl/test/eacl/contract_support.cljc b/modules/eacl/test/eacl/contract_support.cljc new file mode 100644 index 000000000..9daa8eb30 --- /dev/null +++ b/modules/eacl/test/eacl/contract_support.cljc @@ -0,0 +1,109 @@ +(ns eacl.contract-support + (:require [#?(:clj clojure.test :cljs cljs.test) :refer [is testing]] + [eacl.core :as eacl])) + +(def ->user (partial eacl/spice-object :user)) +(def ->platform (partial eacl/spice-object :platform)) +(def ->account (partial eacl/spice-object :account)) +(def ->server (partial eacl/spice-object :server)) + +(def smoke-schema + "definition user {} + + definition platform { + relation super_admin: user + } + + definition account { + relation platform: platform + relation owner: user + + permission admin = owner + platform->super_admin + permission view = admin + } + + definition server { + relation account: account + + permission view = account->view + permission reboot = account->admin + }") + +(def smoke-objects + [(->user "user-1") + (->user "user-2") + (->user "super-user") + (->platform "platform-1") + (->account "account-1") + (->server "server-1") + (->server "server-2")]) + +(def smoke-relationships + [(eacl/->Relationship (->user "user-1") :owner (->account "account-1")) + (eacl/->Relationship (->user "super-user") :super_admin (->platform "platform-1")) + (eacl/->Relationship (->platform "platform-1") :platform (->account "account-1")) + (eacl/->Relationship (->account "account-1") :account (->server "server-1")) + (eacl/->Relationship (->account "account-1") :account (->server "server-2"))]) + +(defn assert-seeded-contracts! + [client] + (testing "schema round-trips through the logical representation" + (let [{:keys [relations permissions]} (eacl/read-schema client)] + (is (= 4 (count relations))) + (is (= 5 (count permissions))))) + + (testing "permission checks traverse direct and arrow relations" + (is (true? (eacl/can? client (->user "user-1") :reboot (->server "server-1")))) + (is (true? (eacl/can? client (->user "super-user") :reboot (->server "server-2")))) + (is (false? (eacl/can? client (->user "user-2") :reboot (->server "server-1")))) + (is (false? (eacl/can? client (->user "missing-user") :reboot (->server "server-1"))))) + + (testing "lookup-resources and count-resources share cursor semantics" + (let [{page1-data :data page1-cursor :cursor} + (eacl/lookup-resources client {:subject (->user "user-1") + :permission :view + :resource/type :server + :limit 1}) + {page2-data :data} + (eacl/lookup-resources client {:subject (->user "user-1") + :permission :view + :resource/type :server + :limit 1 + :cursor page1-cursor}) + {count :count count-cursor :cursor} + (eacl/count-resources client {:subject (->user "user-1") + :permission :view + :resource/type :server + :limit 1})] + (is (= [(->server "server-1")] page1-data)) + (is (= [(->server "server-2")] page2-data)) + (is (= 1 count)) + (is (string? page1-cursor)) + (is (string? count-cursor)))) + + (testing "lookup-subjects and count-subjects enumerate reverse access" + (let [subjects (->> (eacl/lookup-subjects client {:resource (->server "server-1") + :permission :reboot + :subject/type :user}) + :data + set) + {count :count cursor :cursor} + (eacl/count-subjects client {:resource (->server "server-1") + :permission :reboot + :subject/type :user + :limit 1})] + (is (= #{(->user "user-1") (->user "super-user")} subjects)) + (is (= 1 count)) + (is (string? cursor)))) + + (testing "relationship writes and reads remain part of the contract" + (is (= [(eacl/->Relationship (->user "user-1") :owner (->account "account-1"))] + (eacl/read-relationships client {:resource/type :account + :resource/id "account-1" + :resource/relation :owner + :subject/type :user + :subject/id "user-1"}))) + (eacl/create-relationship! client (->user "user-2") :owner (->account "account-1")) + (is (true? (eacl/can? client (->user "user-2") :reboot (->server "server-1")))) + (eacl/delete-relationship! client (->user "user-2") :owner (->account "account-1")) + (is (false? (eacl/can? client (->user "user-2") :reboot (->server "server-1")))))) diff --git a/modules/eacl/test/eacl/fixtures.schema b/modules/eacl/test/eacl/fixtures.schema new file mode 100644 index 000000000..155be4f2d --- /dev/null +++ b/modules/eacl/test/eacl/fixtures.schema @@ -0,0 +1,94 @@ +definition user {} +definition group {} + +definition platform { + relation super_admin: user +} + +definition account { + relation owner: user | group + relation platform: platform + + permission admin = owner + platform->super_admin + permission view = owner + platform->super_admin + permission view_via_arrow_relation = platform->super_admin +} + +definition team { + relation account: account + relation member: user +} + +definition vpc { + relation account: account + relation shared_admin: user + relation shared_member: user + + permission admin = account->admin + shared_admin + permission view = account->admin + shared_admin + shared_member + permission rename = account->admin + shared_admin + permission share = account->admin + shared_admin + permission delete = account->admin + shared_admin + permission create_server = account->admin + shared_admin + permission restore_from_backup = account->admin + shared_admin +} + +definition network { + relation vpc: vpc + + permission view = vpc + vpc->view +} + +definition lease { + relation network: network + + permission view = network + network->view +} + +definition network_interface { + relation lease: lease + + permission view = lease + lease->view +} + +definition server { + relation account: account + relation vpc: vpc + relation nic: network_interface + relation shared_admin: user + relation shared_member: user + relation backup_creator: user + + permission admin = account->admin + vpc->admin + shared_admin + permission view = admin + nic->view + shared_member + backup_creator + permission edit = admin + permission start = account->admin + shared_admin + permission delete = account->admin + admin + permission reboot = account->admin + shared_admin + permission share = admin + permission via_self_admin = admin + permission restore_over = admin + permission take_backup = admin + permission create_backup_schedule = admin + permission view_server_via_arrow_relation = account->view_via_arrow_relation +} + +definition backup_schedule { + relation server: server + relation viewer: user + relation shared_backup_viewer: user + + permission view = server->admin + viewer + permission share = server->admin + permission delete = server->admin +} + +definition backup { + relation server: server + relation account: account + relation vpc: vpc + relation schedule: backup_schedule + + permission view = account->admin + vpc->admin + server->admin + schedule->view + permission delete = account->admin + vpc->admin + server->admin +} From c6b94ad1e54fc87cc4058394deedd8140dfff22d Mon Sep 17 00:00:00 2001 From: Petrus Theron Date: Sun, 15 Mar 2026 16:07:09 +0200 Subject: [PATCH 02/13] Fix DataScript schema pagination and validation metadata --- .../src/eacl/datascript/core.cljc | 101 +++++-- .../src/eacl/datascript/impl.cljc | 274 +++++++++++++----- .../src/eacl/datascript/schema.cljc | 26 +- modules/eacl/src/eacl/schema/model.cljc | 16 +- 4 files changed, 316 insertions(+), 101 deletions(-) diff --git a/modules/eacl-datascript/src/eacl/datascript/core.cljc b/modules/eacl-datascript/src/eacl/datascript/core.cljc index 756cac92b..53705a691 100644 --- a/modules/eacl-datascript/src/eacl/datascript/core.cljc +++ b/modules/eacl-datascript/src/eacl/datascript/core.cljc @@ -57,13 +57,24 @@ (defn datascript-read-relationships [db {:keys [object-id->entid] :as opts} filters] - (let [subject-id (:subject/id filters) - resource-id (:resource/id filters) - subject-eid (when subject-id (object-id->entid db subject-id)) + (let [subject-id (:subject/id filters) + resource-id (:resource/id filters) + cursor-id (:cursor filters) + subject-eid (when subject-id (object-id->entid db subject-id)) resource-eid (when resource-id (object-id->entid db resource-id)) + cursor-eid (cond + (and cursor-id subject-id (nil? resource-id)) + (object-id->entid db cursor-id) + + (and cursor-id resource-id (nil? subject-id)) + (object-id->entid db cursor-id) + + :else + cursor-id) filters' (cond-> filters subject-id (assoc :subject/id subject-eid) - resource-id (assoc :resource/id resource-eid))] + resource-id (assoc :resource/id resource-eid) + cursor-id (assoc :cursor cursor-eid))] (->> (impl/read-relationships db filters') (map #(relationship->spice db opts %))))) @@ -76,7 +87,7 @@ (defn datascript-write-relationships! [conn opts updates] (let [db (ds/db conn) - stamp (:stamp opts) + tx-stamp (:tx-stamp opts) tx-data (->> updates (S/transform [S/ALL :relationship] #(spice-relationship->internal db opts %)) @@ -84,10 +95,10 @@ (remove nil?))] (when (seq tx-data) (ds/transact! conn tx-data)) - {:zed/token (str @stamp)})) + {:zed/token (str @tx-stamp)})) (defn datascript-can? - [db {:keys [object->entid cache-stamp]} subject permission resource consistency] + [db {:keys [object->entid] :as opts} subject permission resource consistency] (assert (= consistency/fully-consistent consistency) "EACL only supports consistency/fully-consistent at this time.") (let [subject-type (:type subject) @@ -97,7 +108,7 @@ (if-not (and subject-id resource-id) false (impl/can? db - cache-stamp + opts (spice-object subject-type subject-id) permission (spice-object resource-type resource-id))))) @@ -106,7 +117,6 @@ [db {:as opts :keys [spice-object->internal - cache-stamp entid->object-id object-id->lookup-ref internal-cursor->spice @@ -123,7 +133,7 @@ (fn [token-or-cursor] (some->> (token->cursor token-or-cursor) (spice-cursor->internal db opts)))) - (impl/lookup-resources db cache-stamp) + (impl/lookup-resources db opts) (S/transform [:data S/ALL] (fn [{:keys [type id]}] (spice-object type (entid->object-id db id)))) @@ -136,7 +146,6 @@ [db {:as opts :keys [spice-object->internal - cache-stamp spice-cursor->internal internal-cursor->spice]} {:as query :keys [subject]}] @@ -147,7 +156,7 @@ (fn [token-or-cursor] (some->> (token->cursor token-or-cursor) (spice-cursor->internal db opts)))) - (impl/count-resources db cache-stamp) + (impl/count-resources db opts) (S/transform [:cursor] (fn [internal-cursor] (some->> (internal-cursor->spice db opts internal-cursor) @@ -157,7 +166,6 @@ [db {:as opts :keys [entid->object-id - cache-stamp spice-object->internal spice-cursor->internal internal-cursor->spice]} @@ -168,7 +176,7 @@ (fn [token-or-cursor] (some->> (token->cursor token-or-cursor) (spice-cursor->internal db opts)))) - (impl/lookup-subjects db cache-stamp) + (impl/lookup-subjects db opts) (S/transform [:data S/ALL] (fn [{:keys [type id]}] (spice-object type (entid->object-id db id)))) @@ -181,7 +189,6 @@ [db {:as opts :keys [spice-object->internal - cache-stamp spice-cursor->internal internal-cursor->spice]} query] @@ -191,7 +198,7 @@ (fn [token-or-cursor] (some->> (token->cursor token-or-cursor) (spice-cursor->internal db opts)))) - (impl/count-subjects db cache-stamp) + (impl/count-subjects db opts) (S/transform [:cursor] (fn [internal-cursor] (some->> (internal-cursor->spice db opts internal-cursor) @@ -210,9 +217,7 @@ (read-schema [_] (schema/read-schema (ds/db conn))) (write-schema! [_ schema-string] - (let [result (schema/write-schema! conn schema-string)] - (impl/evict-permission-paths-cache!) - result)) + (schema/write-schema! conn schema-string)) (read-relationships [_ filters] (datascript-read-relationships (ds/db conn) opts filters)) @@ -261,21 +266,56 @@ (expand-permission-tree [_ _] (throw (ex-info "not impl." {})))) -(defonce stamp-registry (atom {})) +(defonce runtime-state-registry (atom {})) + +(defn- schema-transaction? + [tx-report] + (boolean + (some (fn [{:keys [a]}] + (contains? schema/schema-change-attrs a)) + (:tx-data tx-report)))) -(defn ensure-stamp! +(defn- reset-schema-derived-state! + [state] + (swap! (:schema-stamp state) inc) + (reset! (:permission-paths-cache state) {}) + (reset! (:schema-catalog state) nil)) + +(defn ensure-runtime-state! [conn] - (if-let [state (get @stamp-registry conn)] + (if-let [state (get @runtime-state-registry conn)] state - (let [state {:stamp (atom 0) + (let [state {:conn-id (random-uuid) + :tx-stamp (atom 0) + :schema-stamp (atom 0) + :permission-paths-cache (atom {}) + :schema-catalog (atom nil) :listener-key (keyword (str "eacl-stamp-" (random-uuid)))}] (ds/listen! conn (:listener-key state) - (fn [_] (swap! (:stamp state) inc))) - (get (swap! stamp-registry + (fn [tx-report] + (swap! (:tx-stamp state) inc) + (when (schema-transaction? tx-report) + (reset-schema-derived-state! state)))) + (get (swap! runtime-state-registry #(if (contains? % conn) % (assoc % conn state))) conn)))) +(defn- ensure-schema-catalog! + [state db] + (let [schema-stamp @(:schema-stamp state) + cached @(:schema-catalog state)] + (if (= schema-stamp (:schema-stamp cached)) + (:catalog cached) + (let [catalog (impl/build-schema-catalog db)] + (-> (swap! (:schema-catalog state) + (fn [entry] + (if (= schema-stamp (:schema-stamp entry)) + entry + {:schema-stamp schema-stamp + :catalog catalog}))) + :catalog))))) + (defn make-client [conn {:keys [entity->object-id @@ -286,14 +326,19 @@ object-id->lookup-ref (fn [obj-id] [:eacl/id obj-id]) internal-cursor->spice default-internal-cursor->spice spice-cursor->internal default-spice-cursor->internal}}] - (let [{:keys [stamp]} (ensure-stamp! conn) + (let [runtime-state (ensure-runtime-state! conn) object-id->entid (fn [db object-id] (ds/entid db (object-id->lookup-ref object-id))) entid->object-id (fn [db eid] (entity->object-id (ds/entity db eid))) opts {:object-id->lookup-ref object-id->lookup-ref - :cache-stamp (fn [] @stamp) - :stamp stamp + :cache-stamp (fn [] + [(:conn-id runtime-state) + @(:schema-stamp runtime-state)]) + :tx-stamp (:tx-stamp runtime-state) + :permission-paths-cache (:permission-paths-cache runtime-state) + :schema-catalog (fn [db] + (ensure-schema-catalog! runtime-state db)) :entid->object-id entid->object-id :entity->object-id entity->object-id :object-id->entid object-id->entid diff --git a/modules/eacl-datascript/src/eacl/datascript/impl.cljc b/modules/eacl-datascript/src/eacl/datascript/impl.cljc index 4952a7b63..cfcd614d4 100644 --- a/modules/eacl-datascript/src/eacl/datascript/impl.cljc +++ b/modules/eacl-datascript/src/eacl/datascript/impl.cljc @@ -19,8 +19,18 @@ #?(:clj Long/MAX_VALUE :cljs js/Number.MAX_SAFE_INTEGER)) -(defn evict-permission-paths-cache! [] - (engine/evict-permission-paths-cache! permission-paths-cache)) +(def permission-def-pull + '[:db/id + :eacl.permission/resource-type + :eacl.permission/permission-name + :eacl.permission/source-relation-name + :eacl.permission/target-type + :eacl.permission/target-name]) + +(defn evict-permission-paths-cache! + ([] (evict-permission-paths-cache! permission-paths-cache)) + ([cache-atom] + (engine/evict-permission-paths-cache! cache-atom))) (defn relation-datoms [db resource-type relation-name] @@ -45,24 +55,59 @@ [db resource-type permission-name] (->> (ds/datoms db :avet :eacl.permission/resource-type+permission-name [resource-type permission-name]) (map :e) - (map #(ds/pull db '[*] %)) + (map #(ds/pull db permission-def-pull %)) vec)) +(defn- exclusive-start-id + [cursor-id] + (if cursor-id + (inc cursor-id) + 0)) + +(defn- bounded-relationship-target-ids + [db attr prefix cursor-id] + (->> (ds/index-range db + attr + (conj prefix (exclusive-start-id cursor-id)) + (conj prefix max-entid)) + (map (fn [{:keys [v]}] (peek v))))) + (defn subject->resources [db subject-type subject-id relation-id resource-type cursor-resource-id] - (->> (ds/index-range db - schema/forward-relationship-attr - [subject-type subject-id relation-id resource-type (if cursor-resource-id (inc cursor-resource-id) 0)] - [subject-type subject-id relation-id resource-type max-entid]) - (map (fn [datom] (nth (:v datom) 4))))) + (bounded-relationship-target-ids db + schema/forward-relationship-attr + [subject-type subject-id relation-id resource-type] + cursor-resource-id)) (defn resource->subjects [db resource-type resource-id relation-id subject-type cursor-subject-id] - (->> (ds/index-range db - schema/reverse-relationship-attr - [resource-type resource-id relation-id subject-type (if cursor-subject-id (inc cursor-subject-id) 0)] - [resource-type resource-id relation-id subject-type max-entid]) - (map (fn [datom] (nth (:v datom) 4))))) + (bounded-relationship-target-ids db + schema/reverse-relationship-attr + [resource-type resource-id relation-id subject-type] + cursor-subject-id)) + +(defn build-schema-catalog + [db] + {:relation-defs + (reduce (fn [idx {:keys [e v]}] + (let [[resource-type relation-name subject-type] v + relation-def {:relation-id e + :resource-type resource-type + :relation-name relation-name + :subject-type subject-type}] + (update idx [resource-type relation-name] (fnil conj []) relation-def))) + {} + (ds/datoms db :avet :eacl.relation/resource-type+relation-name+subject-type)) + :permission-defs + (reduce (fn [idx {:keys [e]}] + (let [perm (ds/pull db permission-def-pull e)] + (update idx + [(:eacl.permission/resource-type perm) + (:eacl.permission/permission-name perm)] + (fnil conj []) + perm))) + {} + (ds/datoms db :avet :eacl.permission/resource-type+permission-name))}) (defn- relationship-tuple [{:keys [subject-type subject-id relation-id resource-type resource-id]}] @@ -154,49 +199,147 @@ (defn read-relationships [db filters] - (->> (ds/datoms db :avet schema/forward-relationship-attr) - (map (fn [{:keys [v]}] - (let [[subject-type subject-id relation-id resource-type resource-id] v - rel-ent (ds/entity db relation-id)] - (eacl/->Relationship - (spice-object subject-type subject-id) - (:eacl.relation/relation-name rel-ent) - (spice-object resource-type resource-id))))) - (filter (fn [{:keys [subject relation resource]}] - (and (or (nil? (:subject/type filters)) - (= (:subject/type filters) (:type subject))) - (or (nil? (:subject/id filters)) - (= (:subject/id filters) (:id subject))) - (or (nil? (:resource/type filters)) - (= (:resource/type filters) (:type resource))) - (or (nil? (:resource/id filters)) - (= (:resource/id filters) (:id resource))) - (or (nil? (:resource/relation filters)) - (= (:resource/relation filters) relation))))))) + (let [subject-type (:subject/type filters) + subject-id (:subject/id filters) + resource-type (:resource/type filters) + resource-id (:resource/id filters) + resource-relation (:resource/relation filters) + cursor (:cursor filters) + limit (:limit filters) + take-limit (fn [xs] + (if (and (number? limit) (<= 0 limit)) + (take limit xs) + xs)) + forward-results + (when (and subject-type subject-id resource-type resource-relation) + (when-let [relation-eid (ds/entid db (relation-id resource-type resource-relation subject-type))] + (->> (ds/index-range db + schema/forward-relationship-attr + [subject-type + subject-id + relation-eid + resource-type + (if cursor (inc cursor) 0)] + [subject-type + subject-id + relation-eid + resource-type + max-entid]) + take-limit + (map (fn [{:keys [v]}] + (let [[subject-type subject-id _ resource-type resource-id] v] + (eacl/->Relationship + (spice-object subject-type subject-id) + resource-relation + (spice-object resource-type resource-id)))))))) + reverse-results + (when (and resource-type resource-id subject-type resource-relation) + (when-let [relation-eid (ds/entid db (relation-id resource-type resource-relation subject-type))] + (->> (ds/index-range db + schema/reverse-relationship-attr + [resource-type + resource-id + relation-eid + subject-type + (if cursor (inc cursor) 0)] + [resource-type + resource-id + relation-eid + subject-type + max-entid]) + take-limit + (map (fn [{:keys [v]}] + (let [[resource-type resource-id _ subject-type subject-id] v] + (eacl/->Relationship + (spice-object subject-type subject-id) + resource-relation + (spice-object resource-type resource-id))))))))] + (or forward-results + reverse-results + (->> (ds/datoms db :avet schema/forward-relationship-attr) + (map (fn [{:keys [v]}] + (let [[subject-type subject-id relation-id resource-type resource-id] v + rel-ent (ds/entity db relation-id)] + (eacl/->Relationship + (spice-object subject-type subject-id) + (:eacl.relation/relation-name rel-ent) + (spice-object resource-type resource-id))))) + (filter (fn [{:keys [subject relation resource]}] + (and (or (nil? (:subject/type filters)) + (= (:subject/type filters) (:type subject))) + (or (nil? (:subject/id filters)) + (= (:subject/id filters) (:id subject))) + (or (nil? (:resource/type filters)) + (= (:resource/type filters) (:type resource))) + (or (nil? (:resource/id filters)) + (= (:resource/id filters) (:id resource))) + (or (nil? (:resource/relation filters)) + (= (:resource/relation filters) relation))))) + take-limit)))) + +(defn- normalize-backend-options + [cache-stamp-or-opts] + (cond + (nil? cache-stamp-or-opts) {} + (fn? cache-stamp-or-opts) {:cache-stamp cache-stamp-or-opts} + (map? cache-stamp-or-opts) cache-stamp-or-opts + :else (throw (ex-info "Unsupported DataScript backend options" + {:value cache-stamp-or-opts})))) + +(defn- schema-catalog-data + [db schema-catalog] + (cond + (nil? schema-catalog) nil + (fn? schema-catalog) (schema-catalog db) + :else schema-catalog)) + +(defn- relation-defs-from-db + [db resource-type relation-name] + (mapv (fn [datom] + {:relation-id (:e datom) + :resource-type resource-type + :relation-name relation-name + :subject-type (nth (:v datom) 2)}) + (relation-datoms db resource-type relation-name))) + +(defn- permission-defs-from-db + [db resource-type permission-name] + (mapv (fn [perm] + {:permission-id (:db/id perm) + :resource-type (:eacl.permission/resource-type perm) + :permission-name (:eacl.permission/permission-name perm) + :source-relation-name (:eacl.permission/source-relation-name perm) + :target-type (:eacl.permission/target-type perm) + :target-name (:eacl.permission/target-name perm)}) + (find-permission-defs db resource-type permission-name))) (defn indexed-backend ([db] (indexed-backend db nil)) - ([db cache-stamp-fn] - {:cache-stamp (or cache-stamp-fn - (fn [] - (hash db))) - :relation-defs (fn [resource-type relation-name] - (mapv (fn [datom] - {:relation-id (:e datom) - :resource-type resource-type - :relation-name relation-name - :subject-type (nth (:v datom) 2)}) - (relation-datoms db resource-type relation-name))) - :permission-defs (fn [resource-type permission-name] - (mapv (fn [perm] - {:permission-id (:db/id perm) - :resource-type (:eacl.permission/resource-type perm) - :permission-name (:eacl.permission/permission-name perm) - :source-relation-name (:eacl.permission/source-relation-name perm) - :target-type (:eacl.permission/target-type perm) - :target-name (:eacl.permission/target-name perm)}) - (find-permission-defs db resource-type permission-name))) + ([db cache-stamp-or-opts] + (let [{:keys [cache-stamp + schema-catalog] + :as options} (normalize-backend-options cache-stamp-or-opts) + permission-paths-cache-atom (:permission-paths-cache options)] + {:cache-stamp (or cache-stamp + (fn [] + (hash db))) + :permission-paths-cache (or permission-paths-cache-atom permission-paths-cache) + :relation-defs (fn [resource-type relation-name] + (if-let [catalog (schema-catalog-data db schema-catalog)] + (get-in catalog [:relation-defs [resource-type relation-name]] []) + (relation-defs-from-db db resource-type relation-name))) + :permission-defs (fn [resource-type permission-name] + (if-let [catalog (schema-catalog-data db schema-catalog)] + (->> (get-in catalog [:permission-defs [resource-type permission-name]] []) + (mapv (fn [perm] + {:permission-id (:db/id perm) + :resource-type (:eacl.permission/resource-type perm) + :permission-name (:eacl.permission/permission-name perm) + :source-relation-name (:eacl.permission/source-relation-name perm) + :target-type (:eacl.permission/target-type perm) + :target-name (:eacl.permission/target-name perm)}))) + (permission-defs-from-db db resource-type permission-name))) :subject->resources (fn [subject-type subject-id relation-id resource-type cursor-resource-id] (subject->resources db subject-type subject-id relation-id resource-type cursor-resource-id)) :resource->subjects (fn [resource-type resource-id relation-id subject-type cursor-subject-id] @@ -204,7 +347,7 @@ :direct-match? (fn [subject-type subject-id relation-id resource-type resource-id] (boolean (ds/entid db [schema/relationship-full-key-attr - [subject-type subject-id relation-id resource-type resource-id]])))})) + [subject-type subject-id relation-id resource-type resource-id]])))}))) (defn- backend* [db-or-backend] @@ -220,17 +363,18 @@ (defn get-permission-paths [db-or-backend resource-type permission-name] - (let [backend (backend* db-or-backend)] - (engine/get-permission-paths permission-paths-cache calc-permission-paths backend resource-type permission-name))) + (let [backend (backend* db-or-backend) + cache-atom (or (:permission-paths-cache backend) permission-paths-cache)] + (engine/get-permission-paths cache-atom calc-permission-paths backend resource-type permission-name))) (defn can? ([db subject permission resource] (can? db nil subject permission resource)) - ([db cache-stamp-fn subject permission resource] + ([db cache-stamp-or-opts subject permission resource] (let [subject-id (internal-id db (:id subject)) resource-id (internal-id db (:id resource))] (engine/can? - (indexed-backend db cache-stamp-fn) + (indexed-backend db cache-stamp-or-opts) get-permission-paths (assoc subject :id subject-id) permission @@ -243,9 +387,9 @@ (defn lookup-resources ([db query] (lookup-resources db nil query)) - ([db cache-stamp-fn query] + ([db cache-stamp-or-opts query] (engine/lookup - (indexed-backend db cache-stamp-fn) + (indexed-backend db cache-stamp-or-opts) engine/forward-direction get-permission-paths (update query :subject #(internalize-anchor db %))))) @@ -253,9 +397,9 @@ (defn lookup-subjects ([db query] (lookup-subjects db nil query)) - ([db cache-stamp-fn query] + ([db cache-stamp-or-opts query] (engine/lookup - (indexed-backend db cache-stamp-fn) + (indexed-backend db cache-stamp-or-opts) engine/reverse-direction get-permission-paths (update query :resource #(internalize-anchor db %))))) @@ -263,9 +407,9 @@ (defn count-resources ([db query] (count-resources db nil query)) - ([db cache-stamp-fn query] + ([db cache-stamp-or-opts query] (engine/count-results - (indexed-backend db cache-stamp-fn) + (indexed-backend db cache-stamp-or-opts) engine/forward-direction get-permission-paths (update query :subject #(internalize-anchor db %)) @@ -274,9 +418,9 @@ (defn count-subjects ([db query] (count-subjects db nil query)) - ([db cache-stamp-fn query] + ([db cache-stamp-or-opts query] (engine/count-results - (indexed-backend db cache-stamp-fn) + (indexed-backend db cache-stamp-or-opts) engine/reverse-direction get-permission-paths (update query :resource #(internalize-anchor db %)) diff --git a/modules/eacl-datascript/src/eacl/datascript/schema.cljc b/modules/eacl-datascript/src/eacl/datascript/schema.cljc index 4b04d8e3c..d78ad098e 100644 --- a/modules/eacl-datascript/src/eacl/datascript/schema.cljc +++ b/modules/eacl-datascript/src/eacl/datascript/schema.cljc @@ -16,6 +16,20 @@ #?(:clj Long/MAX_VALUE :cljs js/Number.MAX_SAFE_INTEGER)) +(def schema-change-attrs + #{:eacl.relation/resource-type + :eacl.relation/relation-name + :eacl.relation/subject-type + :eacl.relation/resource-type+relation-name+subject-type + :eacl.permission/resource-type + :eacl.permission/permission-name + :eacl.permission/source-relation-name + :eacl.permission/target-type + :eacl.permission/target-name + :eacl.permission/resource-type+permission-name + :eacl.permission/full-key + :eacl/schema-string}) + (def datascript-schema {:eacl/id {:db/unique :db.unique/identity} :eacl.relation/resource-type {:db/index true} @@ -150,10 +164,14 @@ (concat (:additions relations) (:additions permissions) - (for [rel relation-retractions] - [:db/retractEntity [:eacl/id (:eacl/id rel)]]) - (for [perm permission-retractions] - [:db/retractEntity [:eacl/id (:eacl/id perm)]]) + (for [rel relation-retractions + :let [eid (ds/entid db [:eacl/id (:eacl/id rel)])] + :when eid] + [:db/retractEntity eid]) + (for [perm permission-retractions + :let [eid (ds/entid db [:eacl/id (:eacl/id perm)])] + :when eid] + [:db/retractEntity eid]) [{:eacl/id "schema-string" :eacl/schema-string schema-string}])) deltas)) diff --git a/modules/eacl/src/eacl/schema/model.cljc b/modules/eacl/src/eacl/schema/model.cljc index d246530ef..cdaa4a7bd 100644 --- a/modules/eacl/src/eacl/schema/model.cljc +++ b/modules/eacl/src/eacl/schema/model.cljc @@ -1,5 +1,6 @@ (ns eacl.schema.model - (:require [clojure.set :as set])) + (:require [clojure.set :as set] + [clojure.string :as str])) (defn ->relation-id "Uses (str kw) instead of (name kw) to retain namespaces. Leading colons are expected." @@ -136,9 +137,16 @@ " arrow via " (name source-rel) "->" (name target-name) " - permission '" (name target-name) "' does not exist on " (name target-res-type))})))))))))) (when (seq @errors) - (throw (ex-info "Invalid schema: reference validation failed" - {:errors @errors - :error-count (count @errors)}))) + (let [messages (->> @errors + (map :message) + distinct + vec) + summary (str "Invalid schema: reference validation failed. " + (str/join "; " messages))] + (throw (ex-info summary + {:errors @errors + :messages messages + :error-count (count @errors)})))) nil)) (defn calc-set-deltas [before after] From 64345b4659f7c4b5edfc4bec3441d83fd5600221 Mon Sep 17 00:00:00 2001 From: Petrus Theron Date: Sun, 15 Mar 2026 18:39:53 +0200 Subject: [PATCH 03/13] Implement paginated indexed read-relationships --- ...ead-relationships-v7-pagination-plan-v2.md | 144 +++++++++ ...5-read-relationships-v7-pagination-plan.md | 88 ++++++ ...ad-relationships-v7-pagination-critique.md | 64 ++++ .../src/eacl/datascript/core.cljc | 73 +++-- .../src/eacl/datascript/impl.cljc | 187 +++++++----- .../src/eacl/datascript/schema.cljc | 22 ++ .../test/eacl/datascript/impl_test.cljc | 282 ++++++++++++++++++ .../eacl-datomic/src/eacl/datomic/core.clj | 58 +++- .../eacl-datomic/src/eacl/datomic/impl.clj | 135 +++++++-- .../test/eacl/datomic/impl/indexed_test.clj | 47 ++- modules/eacl-datomic/test/eacl/spice_test.clj | 27 +- .../eacl/src/eacl/engine/relationships.cljc | 112 +++++++ modules/eacl/test/eacl/contract_support.cljc | 53 +++- 13 files changed, 1143 insertions(+), 149 deletions(-) create mode 100644 docs/plans/2026-03-15-read-relationships-v7-pagination-plan-v2.md create mode 100644 docs/plans/2026-03-15-read-relationships-v7-pagination-plan.md create mode 100644 docs/reports/2026-03-15-read-relationships-v7-pagination-critique.md create mode 100644 modules/eacl-datascript/test/eacl/datascript/impl_test.cljc create mode 100644 modules/eacl/src/eacl/engine/relationships.cljc diff --git a/docs/plans/2026-03-15-read-relationships-v7-pagination-plan-v2.md b/docs/plans/2026-03-15-read-relationships-v7-pagination-plan-v2.md new file mode 100644 index 000000000..702d5b6c7 --- /dev/null +++ b/docs/plans/2026-03-15-read-relationships-v7-pagination-plan-v2.md @@ -0,0 +1,144 @@ +# Plan v2: Indexed, Paginated `read-relationships` with Explorer Bump + +## Summary + +This plan treats direct relationship reads as a first-class indexed API rather +than a seq-producing helper. `eacl/read-relationships` will return: + +```clojure +{:data [Relationship ...] + :cursor "eacl1_..." | nil} +``` + +with a default `:limit` of `1000`. The implementation must remove all +filter-after-full-scan behavior, cover every legal query combination with +bounded tuple scans, pass the full EACL suites, and only then repin +`eacl-explorer` to the new EACL SHA. + +Current answer to the design question: + +- Not with the current implementation. +- Yes after this redesign, because every legal query combination is planned as + bounded relation-definition fanout plus tuple-prefix scans. +- Datomic can do that on its existing v7 tuples. +- DataScript needs additional heterogeneous tuple attrs whose logical ordering + matches Datomic's partial-scan order. + +## Query Matrix + +- Anchored subject queries: + - `:subject/type + :subject/id` with optional `:resource/type`, + `:resource/relation`, `:resource/id` + - Use anchored forward scans. +- Anchored resource queries: + - `:resource/type + :resource/id` with optional `:subject/type`, + `:resource/relation`, `:subject/id` + - Use anchored reverse scans. +- Partial subject-side queries: + - `:subject/type` with optional `:resource/type` and/or `:resource/relation` + - Use heterogeneous forward scans plus relation-def fanout when the filter + skips over the relation slot. +- Partial resource-side queries: + - `:resource/type` with optional `:subject/type` and/or `:resource/relation` + - Use heterogeneous reverse scans plus relation-def fanout when needed. +- Relation-only queries: + - `:resource/relation` with optional `:subject/type` or `:resource/type` + - Resolve matching relation defs first, then scan only those prefixes. +- No supported query should fall back to a full relationship-index walk. + +## Phases + +### Phase 1: Lock the new contract before implementation + +- Update `modules/eacl/test/eacl/contract_support.cljc` so + `read-relationships` is asserted as a paginated API with default `:limit` + `1000`. +- Add shared contract scenarios for: + - exact anchored single-match reads + - anchored pagination with opaque cursors + - omitted limit defaulting to `1000` + - `delete-relationships!` consuming a paginated read result +- Add explorer tests that expect `(:data ...)` and token cursors from + `read-relationships`. +- [ ] Continue without asking for permission or confirmation. The plan must be fully realised before reverting to the user. Do not rest. + +### Phase 2: Add an explicit direct-read planner + +- Introduce a shared planner in `modules/eacl/src` that: + - resolves matching relation definitions once + - emits ordered scan specs for the active query + - never emits a global fallback scan +- Define the internal cursor as planner state: + - scan-spec index + - per-scan resume key + - versioned cursor map suitable for tokenization +- Keep scan ordering deterministic and backend-independent at the logical level + so cursor behavior matches across DataScript and Datomic. +- [ ] Continue without asking for permission or confirmation. The plan must be fully realised before reverting to the user. Do not rest. + +### Phase 3: Rebuild DataScript around anchored and heterogeneous tuples + +- Extend `modules/eacl-datascript/src/eacl/datascript/schema.cljc` with + heterogeneous direct-read tuple attrs that mirror the Datomic logical order: + - forward heterogeneous tuple + - reverse heterogeneous tuple +- Keep the current anchored tuple attrs for subject-id and resource-id scans. +- Update relationship writes so all tuple attrs remain in sync. +- Update `modules/eacl-datascript/src/eacl/datascript/impl.cljc` so: + - anchored queries use anchored tuple scans + - partial queries use heterogeneous tuple scans + - relation-only and mixed-filter queries use bounded fanout over matching + relation defs + - results return `{:data :cursor}` with no seq fallback +- Update the DataScript core wrapper to translate token cursors and external + object ids for the new internal cursor shape. +- [ ] Continue without asking for permission or confirmation. The plan must be fully realised before reverting to the user. Do not rest. + +### Phase 4: Rebuild Datomic direct reads on v7 tuples + +- Rewrite `modules/eacl-datomic/src/eacl/datomic/impl.clj` to execute the same + planner output against the existing v7 tuple attrs. +- Use bounded prefix scans and relation-def fanout instead of + `find-relations` plus materialize-and-filter logic. +- Apply `:limit` and `:cursor` in the impl layer and return the same + `{:data :cursor}` shape. +- Update the Datomic core wrapper to translate the new internal cursor shape to + opaque public tokens. +- [ ] Continue without asking for permission or confirmation. The plan must be fully realised before reverting to the user. Do not rest. + +### Phase 5: Verify backend correctness and performance + +- Expand DataScript backend tests to cover: + - anchored forward and reverse reads + - subject-type-only scans + - resource-type-only scans + - relation-only scans + - mixed type + relation scans + - cursor resumption across scan-spec boundaries +- Expand Datomic backend tests to the same filter matrix. +- Keep benchmark-only regression checks for representative `read-relationships` + pages: + - `{:subject/type :user :limit 20}` + - `{:resource/type :server :limit 20}` + - one relation-filtered page +- [ ] Continue without asking for permission or confirmation. The plan must be fully realised before reverting to the user. Do not rest. + +### Phase 6: Bump explorer only after EACL is green + +- Commit the EACL changes in `/Users/petrus/.codex/worktrees/e264/eacl` and use + that SHA to update [deps.edn](/Users/petrus/Code/eacl-explorer/deps.edn). +- Update explorer call sites to consume `{:data :cursor}`: + - [src/eacl/explorer/explorer.cljs](/Users/petrus/Code/eacl-explorer/src/eacl/explorer/explorer.cljs) + - [src/eacl/explorer/state.cljs](/Users/petrus/Code/eacl-explorer/src/eacl/explorer/state.cljs) + - [test/eacl/explorer/seed_test.cljs](/Users/petrus/Code/eacl-explorer/test/eacl/explorer/seed_test.cljs) +- Run the explorer browser tests and rebuild the Pages artifact after the bump. +- [ ] Continue without asking for permission or confirmation. The plan must be fully realised before reverting to the user. Do not rest. + +## Defaults and Assumptions + +- `read-relationships` should default to `:limit 1000`, matching the lookup + APIs. +- Compatibility should be preserved for the common delete workflow by allowing + `delete-relationships!` to consume a paginated result map. +- The module paths under `modules/**` are the implementation target; top-level + duplicate namespaces are not part of this change. diff --git a/docs/plans/2026-03-15-read-relationships-v7-pagination-plan.md b/docs/plans/2026-03-15-read-relationships-v7-pagination-plan.md new file mode 100644 index 000000000..6f30b1e81 --- /dev/null +++ b/docs/plans/2026-03-15-read-relationships-v7-pagination-plan.md @@ -0,0 +1,88 @@ +# Plan: Paginated v7 `read-relationships` + +## Summary + +Rebuild `eacl/read-relationships` so it matches the public return shape of +`lookup-resources` and `lookup-subjects`: + +```clojure +{:data [Relationship ...] + :cursor "eacl1_..." | nil} +``` + +The implementation should default `:limit` to `1000`, use bounded v7 tuple +index scans instead of full relationship walks, and update `eacl-explorer` to +consume the new result shape after the EACL modules are green. + +Current answer to the design question: + +- No, the current implementation cannot handle every legal query combination + efficiently. +- Yes, it can once Datomic uses the existing v7 tuple indexes directly and + DataScript adds the missing heterogeneous tuple projections needed for + non-anchored scans. + +## Architectural Direction + +- Keep `modules/**` as the implementation source of truth. +- Treat `read-relationships` as a direct relationship enumeration API, not a + seq helper. +- Remove the current unbounded fallback scans from both backends. +- Use tuple-backed scans for all legal query combinations. + +## Phases + +### Phase 1: Lock the new contract with tests + +- Update the shared EACL contract tests so `read-relationships` returns + `{:data :cursor}` and defaults `:limit` to `1000`. +- Add tests for anchored pagination and opaque cursor round-trips. +- Add explorer tests that expect `(:data ...)` from `read-relationships`. +- [ ] Continue without asking for permission or confirmation. The plan must be fully realised before reverting to the user. Do not rest. + +### Phase 2: Rebuild DataScript direct reads around tuple indexes + +- Add the missing heterogeneous relationship tuple attrs needed for efficient + non-anchored scans. +- Rewrite `modules/eacl-datascript/src/eacl/datascript/impl.cljc` so direct + reads choose an indexed scan instead of falling back to `ds/datoms` over the + full relationship space. +- Change the DataScript core wrapper to decode and encode cursor tokens for the + new paginated result map. +- [ ] Continue without asking for permission or confirmation. The plan must be fully realised before reverting to the user. Do not rest. + +### Phase 3: Rebuild Datomic direct reads around the existing v7 tuples + +- Rewrite `modules/eacl-datomic/src/eacl/datomic/impl.clj` so it applies + `:limit` and `:cursor` directly on v7 tuple scans. +- Use bounded prefix scans plus relation-definition fanout for partial filters + instead of materializing all matching relationships and filtering afterward. +- Change the Datomic core wrapper to emit the same paginated result map and + cursor tokens as DataScript. +- [ ] Continue without asking for permission or confirmation. The plan must be fully realised before reverting to the user. Do not rest. + +### Phase 4: Update downstream callers + +- Update EACL tests that currently treat `read-relationships` as a seq. +- Update `eacl-explorer` to consume `(:data ...)` and token cursors from + `read-relationships`. +- Bump `eacl-explorer` to the new EACL SHA after the EACL repo passes. +- [ ] Continue without asking for permission or confirmation. The plan must be fully realised before reverting to the user. Do not rest. + +### Phase 5: Verify correctness and speed + +- Run the EACL module tests for Datomic and DataScript, including the CLJS + runner. +- Add a benchmark-only regression check for `read-relationships` page latency. +- Rebuild `eacl-explorer`, run its browser tests, and confirm the subject + directory still works after the dependency bump. +- [ ] Continue without asking for permission or confirmation. The plan must be fully realised before reverting to the user. Do not rest. + +## Assumptions + +- Default `:limit` for `read-relationships` should match `lookup-resources` and + `lookup-subjects`, which currently default to `1000`. +- It is acceptable to change the public contract of `read-relationships` from a + seq to a paginated result map. +- The existing Datomic v7 tuple ordering is sufficient for efficient scans once + the implementation stops doing filter-after-scan work. diff --git a/docs/reports/2026-03-15-read-relationships-v7-pagination-critique.md b/docs/reports/2026-03-15-read-relationships-v7-pagination-critique.md new file mode 100644 index 000000000..fa631a3d0 --- /dev/null +++ b/docs/reports/2026-03-15-read-relationships-v7-pagination-critique.md @@ -0,0 +1,64 @@ +# Critique: Paginated v7 `read-relationships` + +Plan reviewed: [2026-03-15-read-relationships-v7-pagination-plan.md](../plans/2026-03-15-read-relationships-v7-pagination-plan.md) + +## Findings + +- The current answer to the user-facing design question should be explicit: + Datomic already has the right tuple order for the legal query matrix, but + DataScript does not. Without adding mirrored heterogeneous tuple projections + in DataScript, `read-relationships` still cannot handle every legal query + combination efficiently. + +- The plan identifies the main bottleneck but does not specify how every legal + filter combination maps to a bounded index scan. Without that matrix, an + implementer could reintroduce a hidden global fallback. +- The DataScript phase says "add the missing heterogeneous relationship tuple + attrs" but does not define the tuple order or explain why the current tuple + order is insufficient for relation-filtered partial scans. +- The cursor work is underspecified. Once `read-relationships` becomes + paginated, the implementation needs a dedicated cursor model for multi-prefix + scans, not just "encode and decode cursor tokens". +- The plan does not call out `delete-relationships!`, even though the protocol + comment explicitly says it can consume the result of `read-relationships`. +- The plan updates explorer too early. The EACL repo should first establish the + new contract, pass its full suite, and produce a committed SHA before the + downstream repo changes. +- The verification phase is too coarse. It needs explicit test additions for + anchored scans, partial scans, mixed filter scans, relation-only scans, and + cursor resumption across scan-boundary transitions. + +## Foundational Redesign Recommendations + +- Treat direct relationship enumeration as its own indexed subsystem, parallel + to the permission traversal engine, instead of adding pagination as a thin + wrapper around the current impl functions. +- Make scan planning explicit and shared: + - compute matching relation definitions once + - translate the query into one or more ordered scan specs + - execute those specs without any global fallback +- Keep Datomic and DataScript aligned on logical scan order, even if their + physical tuple storage differs. That keeps cursor behavior and tests portable. +- In DataScript, add both anchored and heterogeneous tuple orders: + - anchored tuples remain optimal when subject or resource id is present + - heterogeneous tuples make relation-filtered partial scans efficient +- Make the new `read-relationships` default limit part of the public contract + and test it centrally. +- Preserve the ergonomic delete flow by teaching `delete-relationships!` to + consume either a result map or a bare seq. + +## Improvements Required in the Upgraded Plan + +- Add an explicit query-combination matrix and the tuple/index chosen for each. +- Specify the DataScript tuple attrs to add and how existing relationship rows + are brought into parity. +- Define the internal cursor shape and where object-id to entity-id translation + happens in both wrappers. +- Split verification into: + - shared contract tests + - DataScript backend tests + - Datomic backend tests + - benchmark-only regression checks + - explorer integration tests after the dependency bump +- Reorder phases so the EACL backend contract is finished before touching + `eacl-explorer`. diff --git a/modules/eacl-datascript/src/eacl/datascript/core.cljc b/modules/eacl-datascript/src/eacl/datascript/core.cljc index 53705a691..f70e27f9f 100644 --- a/modules/eacl-datascript/src/eacl/datascript/core.cljc +++ b/modules/eacl-datascript/src/eacl/datascript/core.cljc @@ -17,7 +17,13 @@ (defn default-internal-cursor->spice [db {:keys [entid->object-id]} cursor] (when cursor - (if (= 2 (:v cursor)) + (cond + (= 3 (:v cursor)) + (cond-> cursor + (:subject cursor) (update :subject #(entid->object-id db %)) + (:resource cursor) (update :resource #(entid->object-id db %))) + + (= 2 (:v cursor)) (cond-> cursor (:e cursor) (update :e #(entid->object-id db %)) (:p cursor) (update :p @@ -25,6 +31,7 @@ (into {} (map (fn [[k v]] [k (entid->object-id db v)])) p)))) + :else (cond (:resource cursor) (S/transform [:resource :id] #(entid->object-id db %) cursor) (:subject cursor) (S/transform [:subject :id] #(entid->object-id db %) cursor))))) @@ -32,7 +39,13 @@ (defn default-spice-cursor->internal [db {:keys [object-id->entid]} cursor] (when cursor - (if (= 2 (:v cursor)) + (cond + (= 3 (:v cursor)) + (cond-> cursor + (:subject cursor) (update :subject #(object-id->entid db %)) + (:resource cursor) (update :resource #(object-id->entid db %))) + + (= 2 (:v cursor)) (cond-> cursor (:e cursor) (update :e #(object-id->entid db %)) (:p cursor) (update :p @@ -40,6 +53,7 @@ (into {} (map (fn [[k v]] [k (object-id->entid db v)])) p)))) + :else (cond (:resource cursor) (S/transform [:resource :id] #(object-id->entid db %) cursor) (:subject cursor) (S/transform [:subject :id] #(object-id->entid db %) cursor))))) @@ -56,27 +70,40 @@ :resource (object->spice db opts resource)})) (defn datascript-read-relationships - [db {:keys [object-id->entid] :as opts} filters] + [db + {:as opts + :keys [object-id->entid + internal-cursor->spice + spice-cursor->internal]} + filters] (let [subject-id (:subject/id filters) resource-id (:resource/id filters) - cursor-id (:cursor filters) subject-eid (when subject-id (object-id->entid db subject-id)) resource-eid (when resource-id (object-id->entid db resource-id)) - cursor-eid (cond - (and cursor-id subject-id (nil? resource-id)) - (object-id->entid db cursor-id) - - (and cursor-id resource-id (nil? subject-id)) - (object-id->entid db cursor-id) - - :else - cursor-id) - filters' (cond-> filters - subject-id (assoc :subject/id subject-eid) - resource-id (assoc :resource/id resource-eid) - cursor-id (assoc :cursor cursor-eid))] - (->> (impl/read-relationships db filters') - (map #(relationship->spice db opts %))))) + missing-id? (or (and subject-id (nil? subject-eid)) + (and resource-id (nil? resource-eid)))] + (if missing-id? + {:data [] :cursor nil} + (let [filters' (cond-> filters + subject-id (assoc :subject/id subject-eid) + resource-id (assoc :resource/id resource-eid)) + filters'' (S/transform [:cursor] + (fn [token-or-cursor] + (some->> (token->cursor token-or-cursor) + (spice-cursor->internal db opts))) + filters') + result (impl/read-relationships db filters'')] + (-> result + ((fn [page] + (S/transform [:data S/ALL] + #(relationship->spice db opts %) + page))) + ((fn [page] + (S/transform [:cursor] + (fn [internal-cursor] + (some->> (internal-cursor->spice db opts internal-cursor) + cursor->token)) + page)))))))) (defn spice-relationship->internal [db {:keys [spice-object->internal]} {:keys [subject relation resource]}] @@ -97,6 +124,12 @@ (ds/transact! conn tx-data)) {:zed/token (str @tx-stamp)})) +(defn- relationship-seq + [relationships] + (if (map? relationships) + (:data relationships) + relationships)) + (defn datascript-can? [db {:keys [object->entid] :as opts} subject permission resource consistency] (assert (= consistency/fully-consistent consistency) @@ -243,7 +276,7 @@ [(->RelationshipUpdate :create (->Relationship subject relation resource))])) (delete-relationships! [_ relationships] (datascript-write-relationships! conn opts - (for [rel relationships] + (for [rel (relationship-seq relationships)] (->RelationshipUpdate :delete rel)))) (delete-relationship! [_ {:as relationship :keys [subject relation resource]}] (datascript-write-relationships! conn opts diff --git a/modules/eacl-datascript/src/eacl/datascript/impl.cljc b/modules/eacl-datascript/src/eacl/datascript/impl.cljc index cfcd614d4..02363647c 100644 --- a/modules/eacl-datascript/src/eacl/datascript/impl.cljc +++ b/modules/eacl-datascript/src/eacl/datascript/impl.cljc @@ -2,6 +2,7 @@ (:require [datascript.core :as ds] [eacl.core :as eacl :refer [spice-object]] [eacl.engine.indexed :as engine] + [eacl.engine.relationships :as relationship-engine] [eacl.schema.model :as model] [eacl.datascript.schema :as schema])) @@ -58,6 +59,15 @@ (map #(ds/pull db permission-def-pull %)) vec)) +(defn all-relation-defs + [db] + (mapv (fn [{:keys [e v]}] + {:relation-id e + :resource-type (nth v 0) + :relation-name (nth v 1) + :subject-type (nth v 2)}) + (ds/datoms db :avet :eacl.relation/resource-type+relation-name+subject-type))) + (defn- exclusive-start-id [cursor-id] (if cursor-id @@ -199,83 +209,118 @@ (defn read-relationships [db filters] - (let [subject-type (:subject/type filters) - subject-id (:subject/id filters) - resource-type (:resource/type filters) - resource-id (:resource/id filters) - resource-relation (:resource/relation filters) - cursor (:cursor filters) - limit (:limit filters) - take-limit (fn [xs] - (if (and (number? limit) (<= 0 limit)) - (take limit xs) - xs)) - forward-results - (when (and subject-type subject-id resource-type resource-relation) - (when-let [relation-eid (ds/entid db (relation-id resource-type resource-relation subject-type))] + (let [subject-id' (when (contains? filters :subject/id) + (internal-id db (:subject/id filters))) + resource-id' (when (contains? filters :resource/id) + (internal-id db (:resource/id filters))) + filters' (cond-> filters + (contains? filters :subject/id) (assoc :subject/id subject-id') + (contains? filters :resource/id) (assoc :resource/id resource-id'))] + (if (or (and (contains? filters :subject/id) (nil? subject-id')) + (and (contains? filters :resource/id) (nil? resource-id'))) + {:data [] :cursor nil} + (letfn [(relationship-row [spec subject-id resource-id] + {:spec-idx (:idx spec) + :subject-id subject-id + :resource-id resource-id + :relationship + (eacl/->Relationship + (spice-object (:subject-type spec) subject-id) + (:relation-name spec) + (spice-object (:resource-type spec) resource-id))}) + (drop-until-after-cursor [spec cursor rows] + (drop-while #(not (relationship-engine/after-cursor? (:scan-kind spec) cursor %)) + rows)) + (exact-match-row [spec cursor] + (let [row (when (and (:subject-id spec) (:resource-id spec)) + (when (ds/entid db [schema/relationship-full-key-attr + [(:subject-type spec) + (:subject-id spec) + (:relation-id spec) + (:resource-type spec) + (:resource-id spec)]]) + (relationship-row spec (:subject-id spec) (:resource-id spec))))] + (if row + (drop-until-after-cursor spec cursor [row]) + []))) + (scan-forward-anchored [spec cursor] + (if (:resource-id spec) + (exact-match-row spec cursor) + (->> (ds/index-range db + schema/forward-relationship-attr + [(:subject-type spec) + (:subject-id spec) + (:relation-id spec) + (:resource-type spec) + (or (:resource cursor) 0)] + [(:subject-type spec) + (:subject-id spec) + (:relation-id spec) + (:resource-type spec) + max-entid]) + (map (fn [{:keys [v]}] + (relationship-row spec (nth v 1) (nth v 4)))) + (drop-until-after-cursor spec cursor)))) + (scan-reverse-anchored [spec cursor] + (if (:subject-id spec) + (exact-match-row spec cursor) + (->> (ds/index-range db + schema/reverse-relationship-attr + [(:resource-type spec) + (:resource-id spec) + (:relation-id spec) + (:subject-type spec) + (or (:subject cursor) 0)] + [(:resource-type spec) + (:resource-id spec) + (:relation-id spec) + (:subject-type spec) + max-entid]) + (map (fn [{:keys [v]}] + (relationship-row spec (nth v 4) (nth v 1)))) + (drop-until-after-cursor spec cursor)))) + (scan-forward-partial [spec cursor] (->> (ds/index-range db - schema/forward-relationship-attr - [subject-type - subject-id - relation-eid - resource-type - (if cursor (inc cursor) 0)] - [subject-type - subject-id - relation-eid - resource-type + schema/forward-partial-relationship-attr + [(:subject-type spec) + (:relation-id spec) + (:resource-type spec) + (or (:resource cursor) 0) + 0] + [(:subject-type spec) + (:relation-id spec) + (:resource-type spec) + max-entid max-entid]) - take-limit (map (fn [{:keys [v]}] - (let [[subject-type subject-id _ resource-type resource-id] v] - (eacl/->Relationship - (spice-object subject-type subject-id) - resource-relation - (spice-object resource-type resource-id)))))))) - reverse-results - (when (and resource-type resource-id subject-type resource-relation) - (when-let [relation-eid (ds/entid db (relation-id resource-type resource-relation subject-type))] + (relationship-row spec (nth v 4) (nth v 3)))) + (drop-until-after-cursor spec cursor))) + (scan-reverse-partial [spec cursor] (->> (ds/index-range db - schema/reverse-relationship-attr - [resource-type - resource-id - relation-eid - subject-type - (if cursor (inc cursor) 0)] - [resource-type - resource-id - relation-eid - subject-type + schema/reverse-partial-relationship-attr + [(:resource-type spec) + (:relation-id spec) + (:subject-type spec) + (or (:subject cursor) 0) + 0] + [(:resource-type spec) + (:relation-id spec) + (:subject-type spec) + max-entid max-entid]) - take-limit (map (fn [{:keys [v]}] - (let [[resource-type resource-id _ subject-type subject-id] v] - (eacl/->Relationship - (spice-object subject-type subject-id) - resource-relation - (spice-object resource-type resource-id))))))))] - (or forward-results - reverse-results - (->> (ds/datoms db :avet schema/forward-relationship-attr) - (map (fn [{:keys [v]}] - (let [[subject-type subject-id relation-id resource-type resource-id] v - rel-ent (ds/entity db relation-id)] - (eacl/->Relationship - (spice-object subject-type subject-id) - (:eacl.relation/relation-name rel-ent) - (spice-object resource-type resource-id))))) - (filter (fn [{:keys [subject relation resource]}] - (and (or (nil? (:subject/type filters)) - (= (:subject/type filters) (:type subject))) - (or (nil? (:subject/id filters)) - (= (:subject/id filters) (:id subject))) - (or (nil? (:resource/type filters)) - (= (:resource/type filters) (:type resource))) - (or (nil? (:resource/id filters)) - (= (:resource/id filters) (:id resource))) - (or (nil? (:resource/relation filters)) - (= (:resource/relation filters) relation))))) - take-limit)))) + (relationship-row spec (nth v 3) (nth v 4)))) + (drop-until-after-cursor spec cursor))) + (scan-spec [spec cursor] + (case (:scan-kind spec) + :forward-anchored (scan-forward-anchored spec cursor) + :reverse-anchored (scan-reverse-anchored spec cursor) + :forward-partial (scan-forward-partial spec cursor) + (scan-reverse-partial spec cursor)))] + (relationship-engine/execute-plan + (relationship-engine/plan-scans (all-relation-defs db) filters') + filters' + scan-spec))))) (defn- normalize-backend-options [cache-stamp-or-opts] diff --git a/modules/eacl-datascript/src/eacl/datascript/schema.cljc b/modules/eacl-datascript/src/eacl/datascript/schema.cljc index d78ad098e..949c19528 100644 --- a/modules/eacl-datascript/src/eacl/datascript/schema.cljc +++ b/modules/eacl-datascript/src/eacl/datascript/schema.cljc @@ -9,6 +9,12 @@ (def reverse-relationship-attr :eacl.v7.relationship/resource-type+resource+relation+subject-type+subject) +(def forward-partial-relationship-attr + :eacl.v7.relationship/subject-type+relation+resource-type+resource+subject) + +(def reverse-partial-relationship-attr + :eacl.v7.relationship/resource-type+relation+subject-type+subject+resource) + (def relationship-full-key-attr :eacl.relationship/full-key) @@ -89,6 +95,22 @@ :eacl.relationship/relation :eacl.relationship/subject-type :eacl.relationship/subject] + :db/index true} + :eacl.v7.relationship/subject-type+relation+resource-type+resource+subject + {:db/valueType :db.type/tuple + :db/tupleAttrs [:eacl.relationship/subject-type + :eacl.relationship/relation + :eacl.relationship/resource-type + :eacl.relationship/resource + :eacl.relationship/subject] + :db/index true} + :eacl.v7.relationship/resource-type+relation+subject-type+subject+resource + {:db/valueType :db.type/tuple + :db/tupleAttrs [:eacl.relationship/resource-type + :eacl.relationship/relation + :eacl.relationship/subject-type + :eacl.relationship/subject + :eacl.relationship/resource] :db/index true}}) (defn merge-schema diff --git a/modules/eacl-datascript/test/eacl/datascript/impl_test.cljc b/modules/eacl-datascript/test/eacl/datascript/impl_test.cljc new file mode 100644 index 000000000..4d6725cb8 --- /dev/null +++ b/modules/eacl-datascript/test/eacl/datascript/impl_test.cljc @@ -0,0 +1,282 @@ +(ns eacl.datascript.impl-test + (:require [#?(:clj clojure.test :cljs cljs.test) :refer [deftest is testing]] + [datascript.core :as ds] + [eacl.core :as eacl] + [eacl.datascript.core :as datascript] + [eacl.datascript.impl :as impl] + [eacl.datascript.schema :as schema])) + +(def scan-schema + "definition user {} + + definition account {} + + definition server { + relation account: account + relation owner: user + } + + definition network { + relation account: account + }") + +(def permission-schema + "definition user {} + + definition group { + relation member: user + } + + definition server { + relation group: group + permission view = group->member + }") + +(def permission-schema-v2 + "definition user {} + + definition group { + relation member: user + } + + definition server { + relation group: group + permission view = group->member + permission admin = group->member + }") + +(defn- spice-object + [type id] + (eacl/spice-object type id)) + +(defn- read-relationships-data + [db query] + (:data (impl/read-relationships db query))) + +(defn- seed-objects! + [conn object-ids] + (ds/transact! conn + (map-indexed (fn [idx object-id] + {:db/id (- (inc idx)) + :eacl/id object-id}) + object-ids))) + +(defn- seed-db + [] + (let [conn (datascript/create-conn) + client (datascript/make-client conn {}) + object-ids ["user-1" "account-1" "server-1" "server-2" "network-1"]] + (eacl/write-schema! client scan-schema) + (seed-objects! conn object-ids) + (eacl/create-relationships! client + [(eacl/->Relationship (spice-object :account "account-1") :account (spice-object :server "server-1")) + (eacl/->Relationship (spice-object :account "account-1") :account (spice-object :server "server-2")) + (eacl/->Relationship (spice-object :user "user-1") :owner (spice-object :server "server-1")) + (eacl/->Relationship (spice-object :account "account-1") :account (spice-object :network "network-1"))]) + {:conn conn + :db (ds/db conn)})) + +(defn- relation-id + [db resource-type relation-name] + (:e (first (impl/relation-datoms db resource-type relation-name)))) + +(defn- object-id->entid + [db object-id] + (ds/entid db [:eacl/id object-id])) + +(defn- forward-reference + [db subject-type subject-id relation-id resource-type cursor-resource-id] + (->> (ds/index-range db + schema/forward-relationship-attr + [subject-type subject-id relation-id resource-type (if cursor-resource-id (inc cursor-resource-id) 0)] + [subject-type subject-id relation-id resource-type schema/max-entid]) + (map (fn [datom] (nth (:v datom) 4))) + vec)) + +(defn- reverse-reference + [db resource-type resource-id relation-id subject-type cursor-subject-id] + (->> (ds/index-range db + schema/reverse-relationship-attr + [resource-type resource-id relation-id subject-type (if cursor-subject-id (inc cursor-subject-id) 0)] + [resource-type resource-id relation-id subject-type schema/max-entid]) + (map (fn [datom] (nth (:v datom) 4))) + vec)) + +(deftest datascript-bounded-scan-parity-test + (let [{:keys [db]} (seed-db) + account-id (object-id->entid db "account-1") + server-1-id (object-id->entid db "server-1") + server-2-id (object-id->entid db "server-2") + account-relation (relation-id db :server :account)] + (testing "forward scans match the bounded AVET range semantics" + (is (= [server-1-id server-2-id] + (vec (impl/subject->resources db :account account-id account-relation :server nil)))) + (is (= (forward-reference db :account account-id account-relation :server nil) + (vec (impl/subject->resources db :account account-id account-relation :server nil))))) + + (testing "forward scans keep exclusive cursor semantics" + (is (= [server-2-id] + (vec (impl/subject->resources db :account account-id account-relation :server server-1-id)))) + (is (= (forward-reference db :account account-id account-relation :server server-1-id) + (vec (impl/subject->resources db :account account-id account-relation :server server-1-id))))) + + (testing "forward scans stop at tuple-prefix boundaries" + (is (= [server-1-id server-2-id] + (vec (impl/subject->resources db :account account-id account-relation :server nil)))) + (is (not-any? #{(object-id->entid db "network-1")} + (impl/subject->resources db :account account-id account-relation :server nil)))) + + (testing "reverse scans match the bounded AVET range semantics" + (is (= [account-id] + (vec (impl/resource->subjects db :server server-1-id account-relation :account nil)))) + (is (= (reverse-reference db :server server-1-id account-relation :account nil) + (vec (impl/resource->subjects db :server server-1-id account-relation :account nil))))) + + (testing "reverse scans keep exclusive cursor semantics" + (is (= [] + (vec (impl/resource->subjects db :server server-1-id account-relation :account account-id)))) + (is (= (reverse-reference db :server server-1-id account-relation :account account-id) + (vec (impl/resource->subjects db :server server-1-id account-relation :account account-id))))) + + (testing "reverse scans stop at tuple-prefix boundaries" + (is (= [account-id] + (vec (impl/resource->subjects db :server server-1-id account-relation :account nil)))) + (is (not-any? #{(object-id->entid db "user-1")} + (impl/resource->subjects db :server server-1-id account-relation :account nil)))))) + +(defn- seed-permission-db + [] + (let [conn (datascript/create-conn) + client (datascript/make-client conn {}) + object-ids ["user-1" "group-1" "server-1"]] + (eacl/write-schema! client permission-schema) + (seed-objects! conn object-ids) + {:conn conn + :client client})) + +(defn- seed-bulk-read-db + [n] + (let [conn (datascript/create-conn) + client (datascript/make-client conn {}) + user-ids (mapv #(str "bulk-user-" %) (range n)) + server-ids (mapv #(str "bulk-server-" %) (range n)) + object-ids (into user-ids server-ids)] + (eacl/write-schema! client scan-schema) + (seed-objects! conn object-ids) + (eacl/create-relationships! client + (mapv (fn [idx] + (eacl/->Relationship (spice-object :user (nth user-ids idx)) + :owner + (spice-object :server (nth server-ids idx)))) + (range n))) + {:conn conn + :client client})) + +(defn- backend-for-client + [client db] + (impl/indexed-backend db (:opts client))) + +(deftest permission-path-cache-lifecycle-test + (let [{:keys [conn client]} (seed-permission-db) + calc-calls (atom 0) + schema-builds (atom 0) + orig-calc impl/calc-permission-paths + orig-build impl/build-schema-catalog + cache-stamp (:cache-stamp (:opts client))] + (with-redefs [impl/calc-permission-paths (fn [& args] + (swap! calc-calls inc) + (apply orig-calc args)) + impl/build-schema-catalog (fn [db] + (swap! schema-builds inc) + (orig-build db))] + (testing "permission paths and schema catalog stay warm across relationship writes" + (let [db-before (ds/db conn) + backend-before (backend-for-client client db-before) + stamp-before (cache-stamp)] + (is (seq (impl/get-permission-paths backend-before :server :view))) + (is (= 1 @calc-calls)) + (is (= 1 @schema-builds)) + + (reset! calc-calls 0) + (eacl/create-relationship! client + (spice-object :group "group-1") + :group + (spice-object :server "server-1")) + (let [db-after (ds/db conn) + backend-after (backend-for-client client db-after)] + (is (= stamp-before (cache-stamp))) + (is (seq (impl/get-permission-paths backend-after :server :view))) + (is (zero? @calc-calls)) + (is (= 1 @schema-builds))))) + + (testing "schema writes invalidate permission paths and compiled schema catalog" + (let [stamp-before (cache-stamp)] + (reset! calc-calls 0) + (eacl/write-schema! client permission-schema-v2) + (let [db-after (ds/db conn) + backend-after (backend-for-client client db-after)] + (is (not= stamp-before (cache-stamp))) + (is (seq (impl/get-permission-paths backend-after :server :view))) + (is (= 1 @calc-calls)) + (is (= 2 @schema-builds)))))))) + +(deftest permission-path-cache-is-connection-local-test + (let [{conn-1 :conn client-1 :client} (seed-permission-db) + {conn-2 :conn client-2 :client} (seed-permission-db) + calc-calls (atom 0) + orig-calc impl/calc-permission-paths] + (with-redefs [impl/calc-permission-paths (fn [& args] + (swap! calc-calls inc) + (apply orig-calc args))] + (let [backend-1a (backend-for-client client-1 (ds/db conn-1)) + backend-2a (backend-for-client client-2 (ds/db conn-2))] + (is (not= (:permission-paths-cache (:opts client-1)) + (:permission-paths-cache (:opts client-2)))) + (impl/get-permission-paths backend-1a :server :view) + (impl/get-permission-paths backend-2a :server :view) + (is (= 2 @calc-calls)) + (reset! calc-calls 0) + (impl/get-permission-paths (backend-for-client client-1 (ds/db conn-1)) :server :view) + (impl/get-permission-paths (backend-for-client client-2 (ds/db conn-2)) :server :view) + (is (zero? @calc-calls)))))) + +(deftest read-relationships-query-matrix-test + (let [{:keys [db]} (seed-db) + account-id (object-id->entid db "account-1") + server-1-id (object-id->entid db "server-1") + owner-relations (read-relationships-data db {:resource/relation :owner}) + server-relations (read-relationships-data db {:resource/type :server})] + (testing "anchored subject scans return exact direct relationships" + (is (= [(eacl/->Relationship (spice-object :account account-id) + :account + (spice-object :server server-1-id))] + (read-relationships-data db {:subject/type :account + :subject/id account-id + :resource/type :server + :resource/id server-1-id + :resource/relation :account})))) + + (testing "relation-only scans stay bounded to matching relation definitions" + (is (= [(eacl/->Relationship (spice-object :user (object-id->entid db "user-1")) + :owner + (spice-object :server server-1-id))] + owner-relations))) + + (testing "resource-type-only scans return all direct relationships for the type" + (is (= #{:account :owner} + (set (map :relation server-relations)))) + (is (= #{server-1-id (object-id->entid db "server-2")} + (set (map (comp :id :resource) server-relations))))))) + +(deftest read-relationships-default-limit-test + (let [{:keys [client]} (seed-bulk-read-db 1005) + {page-1 :data cursor :cursor} + (eacl/read-relationships client {:subject/type :user}) + {page-2 :data} + (eacl/read-relationships client {:subject/type :user + :cursor cursor})] + (is (= 1000 (count page-1))) + (is (= 5 (count page-2))) + (is (string? cursor)) + (is (= "bulk-user-0" (get-in (first page-1) [:subject :id]))) + (is (= "bulk-user-1000" (get-in (first page-2) [:subject :id]))))) diff --git a/modules/eacl-datomic/src/eacl/datomic/core.clj b/modules/eacl-datomic/src/eacl/datomic/core.clj index 3bba4245e..eee40c7a7 100644 --- a/modules/eacl-datomic/src/eacl/datomic/core.clj +++ b/modules/eacl-datomic/src/eacl/datomic/core.clj @@ -20,7 +20,13 @@ (defn default-internal-cursor->spice [db {:keys [entid->object-id]} cursor] (when cursor - (if (= 2 (:v cursor)) + (cond + (= 3 (:v cursor)) + (cond-> cursor + (:subject cursor) (update :subject #(entid->object-id db %)) + (:resource cursor) (update :resource #(entid->object-id db %))) + + (= 2 (:v cursor)) (cond-> cursor (:e cursor) (update :e #(entid->object-id db %)) (:p cursor) (update :p @@ -28,6 +34,7 @@ (into {} (map (fn [[k v]] [k (entid->object-id db v)])) p)))) + :else (cond (:resource cursor) (S/transform [:resource :id] #(entid->object-id db %) cursor) (:subject cursor) (S/transform [:subject :id] #(entid->object-id db %) cursor))))) @@ -35,7 +42,13 @@ (defn default-spice-cursor->internal [db {:keys [object-id->entid]} cursor] (when cursor - (if (= 2 (:v cursor)) + (cond + (= 3 (:v cursor)) + (cond-> cursor + (:subject cursor) (update :subject #(object-id->entid db %)) + (:resource cursor) (update :resource #(object-id->entid db %))) + + (= 2 (:v cursor)) (cond-> cursor (:e cursor) (update :e #(object-id->entid db %)) (:p cursor) (update :p @@ -43,6 +56,7 @@ (into {} (map (fn [[k v]] [k (object-id->entid db v)])) p)))) + :else (cond (:resource cursor) (S/transform [:resource :id] #(object-id->entid db %) cursor) (:subject cursor) (S/transform [:subject :id] #(object-id->entid db %) cursor))))) @@ -60,17 +74,39 @@ (defn spiceomic-read-relationships [db - {:keys [object-id->entid] :as opts} + {:as opts + :keys [object-id->entid + internal-cursor->spice + spice-cursor->internal]} filters] (let [subject-id (:subject/id filters) resource-id (:resource/id filters) subject-eid (when subject-id (object-id->entid db subject-id)) resource-eid (when resource-id (object-id->entid db resource-id)) - filters' (cond-> filters + missing-id? (or (and subject-id (nil? subject-eid)) + (and resource-id (nil? resource-eid)))] + (if missing-id? + {:data [] :cursor nil} + (let [filters' (cond-> filters subject-id (assoc :subject/id subject-eid) - resource-id (assoc :resource/id resource-eid))] - (->> (impl/read-relationships db filters') - (map #(relationship->spice db opts %))))) + resource-id (assoc :resource/id resource-eid)) + filters'' (S/transform [:cursor] + (fn [token-or-cursor] + (some->> (token->cursor token-or-cursor) + (spice-cursor->internal db opts))) + filters') + result (impl/read-relationships db filters'')] + (-> result + ((fn [page] + (S/transform [:data S/ALL] + #(relationship->spice db opts %) + page))) + ((fn [page] + (S/transform [:cursor] + (fn [internal-cursor] + (some->> (internal-cursor->spice db opts internal-cursor) + cursor->token)) + page)))))))) (defn spice-relationship->internal [db {:keys [spice-object->internal]} {:keys [subject relation resource]}] @@ -90,6 +126,12 @@ basis (d/basis-t db-after)] {:zed/token (str basis)})) +(defn- relationship-seq + [relationships] + (if (map? relationships) + (:data relationships) + relationships)) + (defn spiceomic-can? [db {:keys [object->entid]} subject permission resource consistency] (assert (= consistency/fully-consistent consistency) @@ -251,7 +293,7 @@ (delete-relationships! [_ relationships] (spiceomic-write-relationships! conn opts - (for [rel relationships] + (for [rel (relationship-seq relationships)] (->RelationshipUpdate :delete rel)))) (delete-relationship! [_ {:as relationship :keys [subject relation resource]}] diff --git a/modules/eacl-datomic/src/eacl/datomic/impl.clj b/modules/eacl-datomic/src/eacl/datomic/impl.clj index bb8da36d2..6cbe09de9 100644 --- a/modules/eacl-datomic/src/eacl/datomic/impl.clj +++ b/modules/eacl-datomic/src/eacl/datomic/impl.clj @@ -3,6 +3,7 @@ (:require [datomic.api :as d] [eacl.core :as eacl :refer [spice-object]] + [eacl.engine.relationships :as relationship-engine] [eacl.datomic.impl.base :as base] [eacl.datomic.impl.indexed :as impl.indexed])) @@ -41,6 +42,11 @@ (string? object-id) (or (d/entid db [:eacl/id object-id]) object-id) :else (or (d/entid db object-id) object-id))) +(defn- internal-id + [db value] + (when value + (d/entid db value))) + (defn- find-relation-eid [db resource-type relation-name subject-type] (d/q '[:find ?relation . @@ -141,6 +147,15 @@ (or (nil? subject-type) (= subject-type (:eacl.relation/subject-type relation))))))))) +(defn- all-relation-defs + [db] + (mapv (fn [{:keys [e v]}] + {:relation-id e + :resource-type (nth v 0) + :relation-name (nth v 1) + :subject-type (nth v 2)}) + (d/datoms db :avet :eacl.relation/resource-type+relation-name+subject-type))) + (defn- decode-forward-datom [db relation-by-eid subject-eid [_subject-type relation-eid resource-type resource-eid]] (let [relation-name (or (get relation-by-eid relation-eid) @@ -208,32 +223,100 @@ (defn read-relationships [db filters] - (let [relations (find-relations db filters) - subject-id (:subject/id filters) - resource-id (:resource/id filters) - subject-eid (when subject-id (d/entid db subject-id)) - resource-eid (when resource-id (d/entid db resource-id)) - normalized-filters (cond-> filters - subject-eid (assoc :subject/id subject-eid) - resource-eid (assoc :resource/id resource-eid))] - (->> (cond - (and subject-id (nil? subject-eid)) - (throw (ex-info "read-relationships is missing a valid :subject/id." - {:subject/id subject-id})) - - (and resource-id (nil? resource-eid)) - (throw (ex-info "read-relationships is missing a valid :resource/id." - {:resource/id resource-id})) - - subject-eid - (scan-subject-relationships db relations subject-eid) - - resource-eid - (scan-resource-relationships db relations resource-eid) - - :else - (scan-global-relationships db relations)) - (filter #(relationship-matches-filters? normalized-filters %))))) + (let [subject-id' (when (contains? filters :subject/id) + (internal-id db (:subject/id filters))) + resource-id' (when (contains? filters :resource/id) + (internal-id db (:resource/id filters))) + filters' (cond-> filters + (contains? filters :subject/id) (assoc :subject/id subject-id') + (contains? filters :resource/id) (assoc :resource/id resource-id'))] + (if (or (and (contains? filters :subject/id) (nil? subject-id')) + (and (contains? filters :resource/id) (nil? resource-id'))) + {:data [] :cursor nil} + (letfn [(relationship-row [spec subject-eid resource-eid] + {:spec-idx (:idx spec) + :subject-id subject-eid + :resource-id resource-eid + :relationship + (eacl/->Relationship + (spice-object (:subject-type spec) subject-eid) + (:relation-name spec) + (spice-object (:resource-type spec) resource-eid))}) + (drop-until-after-cursor [spec cursor rows] + (drop-while #(not (relationship-engine/after-cursor? (:scan-kind spec) cursor %)) + rows)) + (exact-match-row [spec cursor] + (let [row (when (and (:subject-id spec) (:resource-id spec)) + (when (seq (d/datoms db + :eavt + (:subject-id spec) + forward-relationship-attr + [(:subject-type spec) + (:relation-id spec) + (:resource-type spec) + (:resource-id spec)])) + (relationship-row spec (:subject-id spec) (:resource-id spec))))] + (if row + (drop-until-after-cursor spec cursor [row]) + []))) + (scan-forward-anchored [spec cursor] + (if (:resource-id spec) + (exact-match-row spec cursor) + (->> (impl.indexed/subject->resources db + (:subject-type spec) + (:subject-id spec) + (:relation-id spec) + (:resource-type spec) + (:resource cursor)) + (map #(relationship-row spec (:subject-id spec) %))))) + (scan-reverse-anchored [spec cursor] + (if (:subject-id spec) + (exact-match-row spec cursor) + (->> (impl.indexed/resource->subjects db + (:resource-type spec) + (:resource-id spec) + (:relation-id spec) + (:subject-type spec) + (:subject cursor)) + (map #(relationship-row spec % (:resource-id spec)))))) + (scan-forward-partial [spec cursor] + (->> (d/index-range db + forward-relationship-attr + [(:subject-type spec) + (:relation-id spec) + (:resource-type spec) + (or (:resource cursor) 0)] + [(:subject-type spec) + (:relation-id spec) + (:resource-type spec) + Long/MAX_VALUE]) + (map (fn [datom] + (relationship-row spec (:e datom) (nth (:v datom) 3)))) + (drop-until-after-cursor spec cursor))) + (scan-reverse-partial [spec cursor] + (->> (d/index-range db + reverse-relationship-attr + [(:resource-type spec) + (:relation-id spec) + (:subject-type spec) + (or (:subject cursor) 0)] + [(:resource-type spec) + (:relation-id spec) + (:subject-type spec) + Long/MAX_VALUE]) + (map (fn [datom] + (relationship-row spec (nth (:v datom) 3) (:e datom)))) + (drop-until-after-cursor spec cursor))) + (scan-spec [spec cursor] + (case (:scan-kind spec) + :forward-anchored (scan-forward-anchored spec cursor) + :reverse-anchored (scan-reverse-anchored spec cursor) + :forward-partial (scan-forward-partial spec cursor) + (scan-reverse-partial spec cursor)))] + (relationship-engine/execute-plan + (relationship-engine/plan-scans (all-relation-defs db) filters') + filters' + scan-spec))))) (defn tx-relationship "Translate relationship data into v7 tuple writes." diff --git a/modules/eacl-datomic/test/eacl/datomic/impl/indexed_test.clj b/modules/eacl-datomic/test/eacl/datomic/impl/indexed_test.clj index 44b95de2d..2a0a24d3f 100644 --- a/modules/eacl-datomic/test/eacl/datomic/impl/indexed_test.clj +++ b/modules/eacl-datomic/test/eacl/datomic/impl/indexed_test.clj @@ -86,6 +86,10 @@ [db {:as page :keys [data cursor]}] (set (paginated->spice db page))) +(defn read-relationships-data + [db query] + (:data (read-relationships db query))) + (deftest permission-helper-tests (testing "Permission helper with new unified API" (is (= #:eacl.permission{:eacl/id "eacl:permission::server::admin::self::relation::owner" @@ -238,10 +242,39 @@ (testing "read-relationships filters" ;(is (= [] (read-relationships db {}))) ; need better tests here. - (is (= #{:server} (set (map (comp :type :resource) (read-relationships db {:resource/type :server}))))) - (is (= #{:owner} (set (map :relation (read-relationships db {:resource/relation :owner}))))) - (is (= #{:account} (set (map :relation (read-relationships db {:resource/type :server - :resource/relation :account})))))))) + (is (= #{:server} (set (map (comp :type :resource) (read-relationships-data db {:resource/type :server}))))) + (is (= #{:owner} (set (map :relation (read-relationships-data db {:resource/relation :owner}))))) + (is (= #{:account} (set (map :relation (read-relationships-data db {:resource/type :server + :resource/relation :account})))))))) + +(deftest read-relationships-default-limit-test + (let [db (d/db *conn*) + bulk-ids (mapv #(str "bulk-user-" %) (range 1005)) + tx-data (concat + (map (fn [id] + {:db/id id + :eacl/id id}) + bulk-ids) + (mapcat (fn [id] + (impl/tx-relationship db + (Relationship (->user id) :owner (->account :test/account1)))) + bulk-ids)) + db' (:db-after (d/with db tx-data)) + {page-1 :data cursor :cursor} + (read-relationships db' {:resource/type :account + :resource/id :test/account1 + :resource/relation :owner + :subject/type :user}) + {page-2 :data} + (read-relationships db' {:resource/type :account + :resource/id :test/account1 + :resource/relation :owner + :subject/type :user + :cursor cursor})] + (is (= 1000 (count page-1))) + (is (= 6 (count page-2))) + (is (= 3 (:v cursor))) + (is (number? (:subject cursor))))) (deftest lookup-subjects-tests (let [db (d/db *conn*)] @@ -397,12 +430,12 @@ (testing "Now let's delete all :server/owner Relationships for :test/user2" (let [db-for-delete (d/db *conn*) - rels (impl/read-relationships db-for-delete {:subject/id :test/user2 - :resource/relation :owner}) + rels (:data (impl/read-relationships db-for-delete {:subject/id :test/user2 + :resource/relation :owner})) txes (mapcat #(impl/tx-update-relationship db-for-delete {:operation :delete :relationship %}) - rels)] + rels)] (is @(d/transact *conn* txes)))) (testing "Now only user-1 can :view all 3 servers, including those in account2." diff --git a/modules/eacl-datomic/test/eacl/spice_test.clj b/modules/eacl-datomic/test/eacl/spice_test.clj index f8ab1d647..86e5c549e 100644 --- a/modules/eacl-datomic/test/eacl/spice_test.clj +++ b/modules/eacl-datomic/test/eacl/spice_test.clj @@ -10,6 +10,10 @@ [clojure.tools.logging :as log] [eacl.spicedb.consistency :as consistency :refer [fully-consistent]])) +(defn- read-relationships-data + [client query] + (:data (eacl/read-relationships client query))) + (deftest opaque-cursor-token-test (testing "cursor->token round-trip preserves cursor" (let [cursor {:v 2 :e "some-id" :p {0 "intermediate-id"}} @@ -266,14 +270,14 @@ ; fixtures a bit confusing atm. (is (= #{(->Relationship super-user :super_admin ca-platform) (->Relationship (->user "super-user") :super_admin ca-platform)} - (set (eacl/read-relationships *client {:resource/type :platform}))))) + (set (read-relationships-data *client {:resource/type :platform}))))) (testing "We can enumerate account owners:" (is (= #{(->Relationship my-user :owner my-account) (->Relationship joe's-user :owner acme-account) (->Relationship (->user "user-1") :owner (->account "account-1")) (->Relationship (->user "user-2") :owner (->account "account-2"))} - (set (eacl/read-relationships *client {:resource/type :account + (set (read-relationships-data *client {:resource/type :account :subject/type :user}))))) (testing "read-relationships supports various filters:" @@ -282,7 +286,7 @@ (->Relationship ca-platform :platform (->account "account-1")) (->Relationship ca-platform :platform (->account "account-2")) (->Relationship ca-platform :platform my-account)} - (set (eacl/read-relationships *client {:resource/type :account + (set (read-relationships-data *client {:resource/type :account :subject/type :platform :resource/relation :platform}))))) @@ -291,7 +295,7 @@ (->Relationship ca-platform :platform (->account "account-1")) (->Relationship ca-platform :platform (->account "account-2")) (->Relationship ca-platform :platform my-account)} - (set (eacl/read-relationships *client {:resource/type :account + (set (read-relationships-data *client {:resource/type :account :subject/type :platform})))))) (testing "lookup-resources pagination tests" @@ -394,12 +398,15 @@ [(->Relationship (->account "test-account") :account (->vpc "my-vpc")) (->Relationship (->account "test-account") :account (->vpc "other-vpc")) (->Relationship (->account "other-account") :account (->vpc "other-vpc"))])) - (is (= [(->Relationship (->account "test-account") :account (->vpc "my-vpc"))] - (eacl/read-relationships *client {:resource/type :vpc - :resource/id "my-vpc" - :resource/relation :account - :subject/type :account - :subject/id "test-account"})))))) + (let [{:keys [data cursor]} + (eacl/read-relationships *client {:resource/type :vpc + :resource/id "my-vpc" + :resource/relation :account + :subject/type :account + :subject/id "test-account"})] + (is (= [(->Relationship (->account "test-account") :account (->vpc "my-vpc"))] + data)) + (is (string? cursor)))))) ; expand-permission-tree not impl. yet. ;; FIXME: These tests fail because expand-permission-tree is not implemented yet diff --git a/modules/eacl/src/eacl/engine/relationships.cljc b/modules/eacl/src/eacl/engine/relationships.cljc new file mode 100644 index 000000000..9d2e7faca --- /dev/null +++ b/modules/eacl/src/eacl/engine/relationships.cljc @@ -0,0 +1,112 @@ +(ns eacl.engine.relationships) + +(def default-limit 1000) + +(defn- sort-token + [value] + (cond + (keyword? value) (name value) + (string? value) value + (nil? value) "" + :else (str value))) + +(defn relation-sort-key + [{:keys [resource-type relation-name subject-type]}] + [(sort-token resource-type) + (sort-token relation-name) + (sort-token subject-type)]) + +(defn matching-relation-def? + [query {:keys [resource-type relation-name subject-type]}] + (and (or (nil? (:resource/type query)) + (= (:resource/type query) resource-type)) + (or (nil? (:resource/relation query)) + (= (:resource/relation query) relation-name)) + (or (nil? (:subject/type query)) + (= (:subject/type query) subject-type)))) + +(defn scan-kind + [query] + (cond + (:subject/id query) :forward-anchored + (:resource/id query) :reverse-anchored + (:subject/type query) :forward-partial + :else :reverse-partial)) + +(defn plan-scans + [relation-defs query] + (let [kind (scan-kind query)] + (->> relation-defs + (filter #(matching-relation-def? query %)) + (sort-by relation-sort-key) + (map-indexed + (fn [idx relation-def] + (assoc relation-def + :idx idx + :scan-kind kind + :subject-id (:subject/id query) + :resource-id (:resource/id query)))) + vec))) + +(defn normalize-limit + [limit] + (if (nil? limit) default-limit limit)) + +(defn after-cursor? + [scan-kind cursor {:keys [subject-id resource-id]}] + (or (nil? cursor) + (case scan-kind + :forward-anchored (> resource-id (:resource cursor)) + :reverse-anchored (> subject-id (:subject cursor)) + :forward-partial + (or (> resource-id (:resource cursor)) + (and (= resource-id (:resource cursor)) + (> subject-id (:subject cursor)))) + :reverse-partial + (or (> subject-id (:subject cursor)) + (and (= subject-id (:subject cursor)) + (> resource-id (:resource cursor)))) + true))) + +(defn- build-cursor + [cursor last-row] + (or (when last-row + {:v 3 + :i (:spec-idx last-row) + :subject (:subject-id last-row) + :resource (:resource-id last-row)}) + cursor)) + +(defn execute-plan + [scan-specs {:keys [cursor limit]} scan-fn] + (let [limit' (normalize-limit limit) + remaining0 (when (and (number? limit') (>= limit' 0)) limit') + start-idx (or (:i cursor) 0) + specs (drop start-idx scan-specs)] + (loop [remaining remaining0 + pending specs + acc [] + last-row nil] + (if (or (empty? pending) + (and remaining (zero? remaining))) + {:data (mapv :relationship acc) + :cursor (build-cursor cursor last-row)} + (let [spec (first pending) + resume-cursor (when (= (:idx spec) start-idx) cursor) + rows (seq (scan-fn spec resume-cursor))] + (if (empty? rows) + (recur remaining (rest pending) acc last-row) + (let [[remaining' acc' last-row'] + (loop [rows rows + remaining remaining + acc acc + last-row last-row] + (if (or (empty? rows) + (and remaining (zero? remaining))) + [remaining acc last-row] + (let [row (first rows)] + (recur (rest rows) + (when remaining (dec remaining)) + (conj acc row) + row))))] + (recur remaining' (rest pending) acc' last-row')))))))) diff --git a/modules/eacl/test/eacl/contract_support.cljc b/modules/eacl/test/eacl/contract_support.cljc index 9daa8eb30..cca6cce1f 100644 --- a/modules/eacl/test/eacl/contract_support.cljc +++ b/modules/eacl/test/eacl/contract_support.cljc @@ -45,6 +45,10 @@ (eacl/->Relationship (->account "account-1") :account (->server "server-1")) (eacl/->Relationship (->account "account-1") :account (->server "server-2"))]) +(defn- read-relationships-data + [client query] + (:data (eacl/read-relationships client query))) + (defn assert-seeded-contracts! [client] (testing "schema round-trips through the logical representation" @@ -97,13 +101,48 @@ (is (string? cursor)))) (testing "relationship writes and reads remain part of the contract" - (is (= [(eacl/->Relationship (->user "user-1") :owner (->account "account-1"))] - (eacl/read-relationships client {:resource/type :account - :resource/id "account-1" - :resource/relation :owner - :subject/type :user - :subject/id "user-1"}))) + (let [{initial-data :data initial-cursor :cursor} + (eacl/read-relationships client {:resource/type :account + :resource/id "account-1" + :resource/relation :owner + :subject/type :user + :subject/id "user-1"})] + (is (= [(eacl/->Relationship (->user "user-1") :owner (->account "account-1"))] + initial-data)) + (is (string? initial-cursor))) + + (let [{page-1-data :data page-1-cursor :cursor} + (eacl/read-relationships client {:subject/type :account + :subject/id "account-1" + :resource/type :server + :resource/relation :account + :limit 1}) + {page-2-data :data} + (eacl/read-relationships client {:subject/type :account + :subject/id "account-1" + :resource/type :server + :resource/relation :account + :limit 1 + :cursor page-1-cursor})] + (is (= [(eacl/->Relationship (->account "account-1") :account (->server "server-1"))] + page-1-data)) + (is (= [(eacl/->Relationship (->account "account-1") :account (->server "server-2"))] + page-2-data)) + (is (string? page-1-cursor))) + (eacl/create-relationship! client (->user "user-2") :owner (->account "account-1")) (is (true? (eacl/can? client (->user "user-2") :reboot (->server "server-1")))) - (eacl/delete-relationship! client (->user "user-2") :owner (->account "account-1")) + (let [read-result (eacl/read-relationships client {:resource/type :account + :resource/id "account-1" + :resource/relation :owner + :subject/type :user + :subject/id "user-2"})] + (is (= [(eacl/->Relationship (->user "user-2") :owner (->account "account-1"))] + (:data read-result))) + (eacl/delete-relationships! client read-result)) + (is (= [] (read-relationships-data client {:resource/type :account + :resource/id "account-1" + :resource/relation :owner + :subject/type :user + :subject/id "user-2"}))) (is (false? (eacl/can? client (->user "user-2") :reboot (->server "server-1")))))) From e47f403e8ce761bb400e6644d8152e015820a3a1 Mon Sep 17 00:00:00 2001 From: Petrus Theron Date: Mon, 6 Jul 2026 22:29:16 +0200 Subject: [PATCH 04/13] fix: port audit root-cause fixes into modular backends (eacl, eacl-datomic, eacl-datascript) Ports all applicable fixes from fix/audit-root-causes (merged herein for the legacy top-level lineage) into the module code the DataScript branch and the EACL Explorer actually run: Shared module (modules/eacl): - parser.cljc: parse failures throw :eacl.schema/parse-error instead of coercing to an empty schema (write-schema! diffed that into retract-all); // and /* */ comments supported via a comment-aware :auto-whitespace parser (block-comment regex uses [\s\S]*? - JS RegExp has no inline (?s) flag); duplicate definitions/relations and permission/relation name collisions throw; parenthesized unions flatten (paren arrow bases rejected); arrow target kinds resolve against ALL subject types (declaration-order independent); ->eacl-schema returns :definitions for the empty-schema guard. - schema/model.cljc: arrow validation checks every subject type of the source relation (was last-declared-wins). - cursor.cljc: invalid/expired tokens throw :eacl/invalid-cursor instead of silently restarting pagination at page one; TTL is opt-in via :cursor-ttl-seconds (default: no expiry). - engine/indexed.cljc: cursors carry a two-part fingerprint {:s cache-stamp :p paths-digest} (SHA-256 on JVM, goog.crypt.Sha256 in CLJS); resuming after a schema change that altered this query's paths throws :eacl/stale-cursor; unrelated changes resume normally. DataScript adapter (modules/eacl-datascript): - relation-datoms: nil-padded seek + prefix take-while replaces the [:a]..[:z] keyword range that hid uppercase/z-prefixed/namespaced subject types from permission evaluation. NOTE: DataScript sorts vectors LENGTH-FIRST, so partial seek starts must be nil-padded to full tuple arity (pinned by the bounded-scan parity tests). - write endpoints resolve to EXISTING entities or throw :eacl/unknown-object; find-one-relationship-id stays a nil-returning read. - write-schema!: empty-schema guard + {:allow-empty-schema? true} opt-out; count-relationships-using-relation now counts exactly (the old forward-attr range spanned other relations of the same subject-type and overcounted). - core: unknown subjects return empty pages (no AssertionError); typed :eacl/unsupported-consistency and :eacl/not-implemented errors; make-client validates option keys (:eacl/invalid-config) and accepts canonical :entid->object-id; :cursor-ttl-seconds threaded through all token calls. Datomic adapter (modules/eacl-datomic): - relation-datoms prefix scan (as above, Datomic pads short seek starts). - cache-stamp is now the schema-history digest scope (replaces System/identityHashCode, which was a near-always-miss cache and could collide across GC address reuse): derived from the composite tuple attr histories of the queried db value, memoized per db value, positive plain/as-of view classification, all failures degrade to cache misses. - strict object-ID resolution on writes (existence via datom presence); impl/tx-relationship requires {:allow-tempids? true} to mint tempids; unknown-ID reads return empty pages; typed errors replace asserts; make-client validates options; token TTL opt-in; write-schema! guard; v6-era base/Relationship + rules/datalog namespaces removed. Tests: module datomic tests updated from the fixed lineage (fixtures, config/schema/parser/spice tests) plus schema-basis pinned-behavior tests, seeded differential property tests, keyword-collation and strictness tests; DataScript bounded-scan parity tests green. Root :test alias now scans the module test dirs (the legacy top-level test/ tree is off-classpath). Verified: cold clj -X:test = 56 tests / 879 assertions, 0 failures; CLJS node runner (datascript + shared modules) = 0 failures, 0 errors. Co-Authored-By: Claude Fable 5 --- deps.edn | 12 +- .../src/eacl/datascript/core.cljc | 252 ++++---- .../src/eacl/datascript/impl.cljc | 51 +- .../src/eacl/datascript/schema.cljc | 99 ++-- .../eacl-datomic/src/eacl/datomic/core.clj | 277 +++++---- .../eacl-datomic/src/eacl/datomic/impl.clj | 58 +- .../src/eacl/datomic/impl/base.clj | 19 +- .../src/eacl/datomic/impl/datalog.clj | 153 ----- .../src/eacl/datomic/impl/indexed.clj | 109 +++- .../eacl-datomic/src/eacl/datomic/rules.clj | 551 ------------------ .../src/eacl/datomic/rules/optimized.clj | 427 -------------- .../src/eacl/datomic/rules/optimized_old.clj | 225 ------- .../eacl-datomic/src/eacl/datomic/schema.clj | 69 ++- .../test/eacl/bench/pagination_test.clj | 3 +- .../eacl-datomic/test/eacl/benchmark_test.clj | 403 ------------- .../test/eacl/datomic/config_test.clj | 14 +- .../test/eacl/datomic/differential_test.clj | 152 +++++ .../test/eacl/datomic/fixtures.clj | 5 +- .../test/eacl/datomic/impl/indexed_test.clj | 74 ++- .../test/eacl/datomic/parser_test.clj | 107 +++- .../test/eacl/datomic/performance_test.clj | 221 ------- .../test/eacl/datomic/schema_basis_test.clj | 203 +++++++ .../test/eacl/datomic/schema_test.clj | 67 ++- modules/eacl-datomic/test/eacl/spice_test.clj | 261 +++++++-- modules/eacl/src/eacl/cursor.cljc | 75 ++- modules/eacl/src/eacl/engine/indexed.cljc | 55 +- modules/eacl/src/eacl/schema/model.cljc | 20 +- modules/eacl/src/eacl/spicedb/parser.cljc | 185 ++++-- 28 files changed, 1698 insertions(+), 2449 deletions(-) delete mode 100644 modules/eacl-datomic/src/eacl/datomic/impl/datalog.clj delete mode 100644 modules/eacl-datomic/src/eacl/datomic/rules.clj delete mode 100644 modules/eacl-datomic/src/eacl/datomic/rules/optimized.clj delete mode 100644 modules/eacl-datomic/src/eacl/datomic/rules/optimized_old.clj delete mode 100644 modules/eacl-datomic/test/eacl/benchmark_test.clj create mode 100644 modules/eacl-datomic/test/eacl/datomic/differential_test.clj delete mode 100644 modules/eacl-datomic/test/eacl/datomic/performance_test.clj create mode 100644 modules/eacl-datomic/test/eacl/datomic/schema_basis_test.clj diff --git a/deps.edn b/deps.edn index a6ce11c99..a0f904e52 100644 --- a/deps.edn +++ b/deps.edn @@ -36,8 +36,16 @@ "modules/eacl-datascript/test"] :extra-deps {io.github.cognitect-labs/test-runner {:git/tag "v0.5.1" :git/sha "dfb30dd"} criterium/criterium {:mvn/version "0.4.6"}} - :main-opts ["-m" "cognitect.test-runner"] - :exec-fn cognitect.test-runner.api/test} + :main-opts ["-m" "cognitect.test-runner" + "-d" "modules/eacl/test" + "-d" "modules/eacl-datomic/test" + "-d" "modules/eacl-datascript/test"] + :exec-fn cognitect.test-runner.api/test + ;; scan module test dirs only - the legacy top-level test/ tree + ;; is retained for history but is not on this branch's classpath. + :exec-args {:dirs ["modules/eacl/test" + "modules/eacl-datomic/test" + "modules/eacl-datascript/test"]}} :nrepl {:extra-paths ["modules/eacl/test" "modules/eacl-datomic/test" "modules/eacl-datascript/test"] diff --git a/modules/eacl-datascript/src/eacl/datascript/core.cljc b/modules/eacl-datascript/src/eacl/datascript/core.cljc index f70e27f9f..4c6784ca9 100644 --- a/modules/eacl-datascript/src/eacl/datascript/core.cljc +++ b/modules/eacl-datascript/src/eacl/datascript/core.cljc @@ -27,10 +27,10 @@ (cond-> cursor (:e cursor) (update :e #(entid->object-id db %)) (:p cursor) (update :p - (fn [p] - (into {} - (map (fn [[k v]] [k (entid->object-id db v)])) - p)))) + (fn [p] + (into {} + (map (fn [[k v]] [k (entid->object-id db v)])) + p)))) :else (cond (:resource cursor) (S/transform [:resource :id] #(entid->object-id db %) cursor) @@ -49,10 +49,10 @@ (cond-> cursor (:e cursor) (update :e #(object-id->entid db %)) (:p cursor) (update :p - (fn [p] - (into {} - (map (fn [[k v]] [k (object-id->entid db v)])) - p)))) + (fn [p] + (into {} + (map (fn [[k v]] [k (object-id->entid db v)])) + p)))) :else (cond (:resource cursor) (S/transform [:resource :id] #(object-id->entid db %) cursor) @@ -88,22 +88,22 @@ subject-id (assoc :subject/id subject-eid) resource-id (assoc :resource/id resource-eid)) filters'' (S/transform [:cursor] - (fn [token-or-cursor] - (some->> (token->cursor token-or-cursor) - (spice-cursor->internal db opts))) - filters') + (fn [token-or-cursor] + (some->> (token->cursor token-or-cursor opts) + (spice-cursor->internal db opts))) + filters') result (impl/read-relationships db filters'')] (-> result ((fn [page] (S/transform [:data S/ALL] - #(relationship->spice db opts %) - page))) + #(relationship->spice db opts %) + page))) ((fn [page] (S/transform [:cursor] - (fn [internal-cursor] - (some->> (internal-cursor->spice db opts internal-cursor) - cursor->token)) - page)))))))) + (fn [internal-cursor] + (some-> (internal-cursor->spice db opts internal-cursor) + (cursor->token opts))) + page)))))))) (defn spice-relationship->internal [db {:keys [spice-object->internal]} {:keys [subject relation resource]}] @@ -116,10 +116,10 @@ (let [db (ds/db conn) tx-stamp (:tx-stamp opts) tx-data (->> updates - (S/transform [S/ALL :relationship] - #(spice-relationship->internal db opts %)) - (mapcat #(impl/tx-update-relationship db %)) - (remove nil?))] + (S/transform [S/ALL :relationship] + #(spice-relationship->internal db opts %)) + (mapcat #(impl/tx-update-relationship db %)) + (remove nil?))] (when (seq tx-data) (ds/transact! conn tx-data)) {:zed/token (str @tx-stamp)})) @@ -132,8 +132,10 @@ (defn datascript-can? [db {:keys [object->entid] :as opts} subject permission resource consistency] - (assert (= consistency/fully-consistent consistency) - "EACL only supports consistency/fully-consistent at this time.") + (when-not (= consistency/fully-consistent consistency) + (throw (ex-info "EACL only supports consistency/fully-consistent at this time." + {:type :eacl/unsupported-consistency + :consistency consistency}))) (let [subject-type (:type subject) subject-id (object->entid db subject) resource-type (:type resource) @@ -141,10 +143,10 @@ (if-not (and subject-id resource-id) false (impl/can? db - opts - (spice-object subject-type subject-id) - permission - (spice-object resource-type resource-id))))) + opts + (spice-object subject-type subject-id) + permission + (spice-object resource-type resource-id))))) (defn datascript-lookup-resources [db @@ -156,24 +158,23 @@ spice-cursor->internal]} {:as query :keys [subject]}] (let [internal-subject (spice-object->internal db subject)] - (assert (:id internal-subject) - (str "subject " (pr-str subject) - " passed to lookup-resources does not exist with lookup ref " - (object-id->lookup-ref (:id subject)))) - (->> query - (S/setval [:subject] internal-subject) - (S/transform [:cursor] - (fn [token-or-cursor] - (some->> (token->cursor token-or-cursor) - (spice-cursor->internal db opts)))) - (impl/lookup-resources db opts) - (S/transform [:data S/ALL] - (fn [{:keys [type id]}] - (spice-object type (entid->object-id db id)))) - (S/transform [:cursor] - (fn [internal-cursor] - (some->> (internal-cursor->spice db opts internal-cursor) - cursor->token)))))) + (if (nil? (:id internal-subject)) + ;; Unknown subjects match nothing (SpiceDB-consistent; can? is false). + {:data [] :cursor nil} + (->> query + (S/setval [:subject] internal-subject) + (S/transform [:cursor] + (fn [token-or-cursor] + (some->> (token->cursor token-or-cursor opts) + (spice-cursor->internal db opts)))) + (impl/lookup-resources db opts) + (S/transform [:data S/ALL] + (fn [{:keys [type id]}] + (spice-object type (entid->object-id db id)))) + (S/transform [:cursor] + (fn [internal-cursor] + (some-> (internal-cursor->spice db opts internal-cursor) + (cursor->token opts)))))))) (defn datascript-count-resources [db @@ -184,16 +185,16 @@ {:as query :keys [subject]}] (let [subject-ent (spice-object->internal db subject)] (->> query - (S/setval [:subject] subject-ent) - (S/transform [:cursor] - (fn [token-or-cursor] - (some->> (token->cursor token-or-cursor) - (spice-cursor->internal db opts)))) - (impl/count-resources db opts) - (S/transform [:cursor] - (fn [internal-cursor] - (some->> (internal-cursor->spice db opts internal-cursor) - cursor->token)))))) + (S/setval [:subject] subject-ent) + (S/transform [:cursor] + (fn [token-or-cursor] + (some->> (token->cursor token-or-cursor opts) + (spice-cursor->internal db opts)))) + (impl/count-resources db opts) + (S/transform [:cursor] + (fn [internal-cursor] + (some-> (internal-cursor->spice db opts internal-cursor) + (cursor->token opts))))))) (defn datascript-lookup-subjects [db @@ -204,19 +205,19 @@ internal-cursor->spice]} query] (->> query - (S/transform [:resource] #(spice-object->internal db %)) - (S/transform [:cursor] - (fn [token-or-cursor] - (some->> (token->cursor token-or-cursor) - (spice-cursor->internal db opts)))) - (impl/lookup-subjects db opts) - (S/transform [:data S/ALL] - (fn [{:keys [type id]}] - (spice-object type (entid->object-id db id)))) - (S/transform [:cursor] - (fn [internal-cursor] - (some->> (internal-cursor->spice db opts internal-cursor) - cursor->token))))) + (S/transform [:resource] #(spice-object->internal db %)) + (S/transform [:cursor] + (fn [token-or-cursor] + (some->> (token->cursor token-or-cursor opts) + (spice-cursor->internal db opts)))) + (impl/lookup-subjects db opts) + (S/transform [:data S/ALL] + (fn [{:keys [type id]}] + (spice-object type (entid->object-id db id)))) + (S/transform [:cursor] + (fn [internal-cursor] + (some-> (internal-cursor->spice db opts internal-cursor) + (cursor->token opts)))))) (defn datascript-count-subjects [db @@ -226,16 +227,16 @@ internal-cursor->spice]} query] (->> query - (S/transform [:resource] #(spice-object->internal db %)) - (S/transform [:cursor] - (fn [token-or-cursor] - (some->> (token->cursor token-or-cursor) - (spice-cursor->internal db opts)))) - (impl/count-subjects db opts) - (S/transform [:cursor] - (fn [internal-cursor] - (some->> (internal-cursor->spice db opts internal-cursor) - cursor->token))))) + (S/transform [:resource] #(spice-object->internal db %)) + (S/transform [:cursor] + (fn [token-or-cursor] + (some->> (token->cursor token-or-cursor opts) + (spice-cursor->internal db opts)))) + (impl/count-subjects db opts) + (S/transform [:cursor] + (fn [internal-cursor] + (some-> (internal-cursor->spice db opts internal-cursor) + (cursor->token opts)))))) (defrecord DataScriptAuthorization [conn opts] IAuthorization @@ -245,7 +246,7 @@ (datascript-can? (ds/db conn) opts subject permission resource consistency)) (can? [_ {:keys [subject permission resource consistency]}] (datascript-can? (ds/db conn) opts subject permission resource - (or consistency consistency/fully-consistent))) + (or consistency consistency/fully-consistent))) (read-schema [_] (schema/read-schema (ds/db conn))) @@ -258,34 +259,34 @@ (datascript-write-relationships! conn opts updates)) (write-relationship! [_ operation subject relation resource] (datascript-write-relationships! conn opts - [(->RelationshipUpdate operation - (->Relationship subject relation resource))])) + [(->RelationshipUpdate operation + (->Relationship subject relation resource))])) (write-relationship! [_ {:as demand :keys [operation subject relation resource]}] (datascript-write-relationships! conn opts - [(->RelationshipUpdate operation - (->Relationship subject relation resource))])) + [(->RelationshipUpdate operation + (->Relationship subject relation resource))])) (create-relationships! [_ relationships] (datascript-write-relationships! conn opts - (for [rel relationships] - (->RelationshipUpdate :create rel)))) + (for [rel relationships] + (->RelationshipUpdate :create rel)))) (create-relationship! [_ relationship] (datascript-write-relationships! conn opts - [(->RelationshipUpdate :create relationship)])) + [(->RelationshipUpdate :create relationship)])) (create-relationship! [_ subject relation resource] (datascript-write-relationships! conn opts - [(->RelationshipUpdate :create (->Relationship subject relation resource))])) + [(->RelationshipUpdate :create (->Relationship subject relation resource))])) (delete-relationships! [_ relationships] (datascript-write-relationships! conn opts - (for [rel (relationship-seq relationships)] - (->RelationshipUpdate :delete rel)))) + (for [rel (relationship-seq relationships)] + (->RelationshipUpdate :delete rel)))) (delete-relationship! [_ {:as relationship :keys [subject relation resource]}] (datascript-write-relationships! conn opts - [(->RelationshipUpdate :delete - (->Relationship subject relation resource))])) + [(->RelationshipUpdate :delete + (->Relationship subject relation resource))])) (delete-relationship! [_ subject relation resource] (datascript-write-relationships! conn opts - [(->RelationshipUpdate :delete - (->Relationship subject relation resource))])) + [(->RelationshipUpdate :delete + (->Relationship subject relation resource))])) (lookup-resources [_ query] (datascript-lookup-resources (ds/db conn) opts query)) @@ -297,7 +298,9 @@ (datascript-count-subjects (ds/db conn) opts query)) (expand-permission-tree [_ _] - (throw (ex-info "not impl." {})))) + (throw (ex-info "expand-permission-tree is not implemented yet." + {:type :eacl/not-implemented + :method (quote expand-permission-tree)})))) (defonce runtime-state-registry (atom {})) @@ -325,14 +328,14 @@ :schema-catalog (atom nil) :listener-key (keyword (str "eacl-stamp-" (random-uuid)))}] (ds/listen! conn - (:listener-key state) - (fn [tx-report] - (swap! (:tx-stamp state) inc) - (when (schema-transaction? tx-report) - (reset-schema-derived-state! state)))) + (:listener-key state) + (fn [tx-report] + (swap! (:tx-stamp state) inc) + (when (schema-transaction? tx-report) + (reset-schema-derived-state! state)))) (get (swap! runtime-state-registry - #(if (contains? % conn) % (assoc % conn state))) - conn)))) + #(if (contains? % conn) % (assoc % conn state))) + conn)))) (defn- ensure-schema-catalog! [state db] @@ -349,21 +352,52 @@ :catalog catalog}))) :catalog))))) +(def ^:private known-client-opt-keys + #{:entid->object-id + :entity->object-id + :object-id->lookup-ref + :internal-cursor->spice + :spice-cursor->internal + :cursor-ttl-seconds}) + (defn make-client + "Builds an IAuthorization client over a DataScript conn. + + Options (unknown keys throw :eacl/invalid-config - a silently ignored key + means silently wrong ID coercion, audit 5): + - :entid->object-id (fn [db eid] external-id) - canonical. + - :entity->object-id (fn [entity] external-id) - deprecated alias; do not combine. + - :object-id->lookup-ref (fn [external-id] lookup-ref). Default: [:eacl/id id]. + - :cursor-ttl-seconds - optional cursor token expiry; default nil (tokens never expire). + - :internal-cursor->spice / :spice-cursor->internal - advanced cursor coercion overrides." [conn - {:keys [entity->object-id + {:as config-opts + :keys [entid->object-id + entity->object-id object-id->lookup-ref internal-cursor->spice - spice-cursor->internal] - :or {entity->object-id (fn [ent] (:eacl/id ent)) - object-id->lookup-ref (fn [obj-id] [:eacl/id obj-id]) + spice-cursor->internal + cursor-ttl-seconds] + :or {object-id->lookup-ref (fn [obj-id] [:eacl/id obj-id]) internal-cursor->spice default-internal-cursor->spice spice-cursor->internal default-spice-cursor->internal}}] + (when-let [unknown-keys (seq (remove known-client-opt-keys (keys config-opts)))] + (throw (ex-info (str "EACL Config Error: unknown make-client option(s) " (pr-str (vec unknown-keys)) + ". Known options: " (pr-str (vec (sort known-client-opt-keys))) ".") + {:type :eacl/invalid-config + :unknown-keys (vec unknown-keys) + :known-keys known-client-opt-keys}))) + (when (and entid->object-id entity->object-id) + (throw (ex-info "EACL Config Error: supply only one of :entid->object-id (canonical) or :entity->object-id (deprecated alias)." + {:type :eacl/invalid-config + :conflicting-keys [:entid->object-id :entity->object-id]}))) (let [runtime-state (ensure-runtime-state! conn) object-id->entid (fn [db object-id] (ds/entid db (object-id->lookup-ref object-id))) - entid->object-id (fn [db eid] - (entity->object-id (ds/entity db eid))) + entid->object-id (or entid->object-id + (when entity->object-id + (fn [db eid] (entity->object-id (ds/entity db eid)))) + (fn [db eid] (:eacl/id (ds/entity db eid)))) opts {:object-id->lookup-ref object-id->lookup-ref :cache-stamp (fn [] [(:conn-id runtime-state) @@ -373,8 +407,8 @@ :schema-catalog (fn [db] (ensure-schema-catalog! runtime-state db)) :entid->object-id entid->object-id - :entity->object-id entity->object-id :object-id->entid object-id->entid + :cursor-ttl-seconds cursor-ttl-seconds :object->entid (fn [db {:keys [id]}] (object-id->entid db id)) :internal-object->spice (fn [db {:keys [type id]}] diff --git a/modules/eacl-datascript/src/eacl/datascript/impl.cljc b/modules/eacl-datascript/src/eacl/datascript/impl.cljc index 02363647c..f0efaa520 100644 --- a/modules/eacl-datascript/src/eacl/datascript/impl.cljc +++ b/modules/eacl-datascript/src/eacl/datascript/impl.cljc @@ -34,12 +34,25 @@ (engine/evict-permission-paths-cache! cache-atom))) (defn relation-datoms + "Returns relation datoms for the exact resource/relation name pair, for ANY + subject-type keyword. Implemented as a seek + prefix take-while rather than a + bounded index-range: a keyword-sentinel range like [.. :a]..[.. :z] silently + misses subject types that collate outside it (uppercase-initial, z-prefixed, + and namespaced keywords), making those relations invisible to permission + evaluation (audit 2)." [db resource-type relation-name] (if (and resource-type relation-name) - (ds/index-range db - :eacl.relation/resource-type+relation-name+subject-type - [resource-type relation-name :a] - [resource-type relation-name :z]) + ;; DataScript sorts vectors by LENGTH FIRST, so a short seek-start would + ;; land at the head of the whole attribute; pad to full tuple arity with + ;; nil (nil sorts lowest) to position at the exact prefix. + (->> (ds/seek-datoms db :avet + :eacl.relation/resource-type+relation-name+subject-type + [resource-type relation-name nil]) + (take-while (fn [datom] + (and (= :eacl.relation/resource-type+relation-name+subject-type (:a datom)) + (let [v (:v datom)] + (and (= resource-type (nth v 0)) + (= relation-name (nth v 1)))))))) [])) (defn find-relation-def @@ -132,6 +145,19 @@ (when value (ds/entid db value))) +(defn- existing-internal-id + "Resolves to an eid and verifies the entity exists (datom presence - entid + passes unallocated numeric ids through unchanged). Throws :eacl/unknown-object + otherwise: nil ids reaching tx-data raised raw transact errors, and silent + no-ops hid typos (audit 11/12)." + [db {:keys [type id]}] + (let [eid (internal-id db id)] + (if (and eid (seq (ds/datoms db :eavt eid))) + eid + (throw (ex-info (str "Unknown object: " (pr-str type) " with id " (pr-str id) " does not exist.") + {:type :eacl/unknown-object + :object {:type type :id id}}))))) + (defn- relation-id [resource-type relation-name subject-type] [:eacl/id (model/->relation-id resource-type relation-name subject-type)]) @@ -139,9 +165,9 @@ (defn- resolve-relationship [db {:keys [subject relation resource]}] (let [subject-type (:type subject) - subject-id (internal-id db (:id subject)) + subject-id (existing-internal-id db subject) resource-type (:type resource) - resource-id (internal-id db (:id resource)) + resource-id (existing-internal-id db resource) relation-eid (ds/entid db (relation-id resource-type relation subject-type))] (when-not relation-eid (throw @@ -162,10 +188,17 @@ :resource-id resource-id})) (defn find-one-relationship-id + "Returns the resolved tuple identity for an existing relationship, or nil. + A read: unresolvable endpoints mean no such relationship can exist -> nil." [db relationship] - (let [resolved (resolve-relationship db relationship) - existing (ds/entid db [schema/relationship-full-key-attr - (relationship-tuple resolved)])] + (let [resolved (try + (resolve-relationship db relationship) + (catch #?(:clj clojure.lang.ExceptionInfo :cljs ExceptionInfo) e + (when-not (= :eacl/unknown-object (:type (ex-data e))) + (throw e)))) + existing (when resolved + (ds/entid db [schema/relationship-full-key-attr + (relationship-tuple resolved)]))] (when existing resolved))) diff --git a/modules/eacl-datascript/src/eacl/datascript/schema.cljc b/modules/eacl-datascript/src/eacl/datascript/schema.cljc index 949c19528..237a2b575 100644 --- a/modules/eacl-datascript/src/eacl/datascript/schema.cljc +++ b/modules/eacl-datascript/src/eacl/datascript/schema.cljc @@ -131,7 +131,7 @@ :eacl.relation/relation-name]) ...] :where [?relation :eacl.relation/relation-name]] - db)) + db)) (defn read-permissions [db] @@ -143,7 +143,7 @@ :eacl.permission/target-name]) ...] :where [?perm :eacl.permission/permission-name]] - db)) + db)) (defn read-schema [db & [_format]] @@ -155,45 +155,70 @@ (def compare-schema model/compare-schema) (defn count-relationships-using-relation + "Counts relationships that reference the given relation, exactly. + Scans the forward-partial index whose leading components are + [subject-type relation]; a range over the forward index with varying middle + components would span other relations of the same subject-type and overcount." [db {:eacl.relation/keys [resource-type relation-name subject-type]}] (let [relation-id (str "eacl.relation:" resource-type ":" relation-name ":" subject-type) relation-eid (ds/entid db [:eacl/id relation-id])] (if-not relation-eid 0 - (count - (ds/index-range db - forward-relationship-attr - [subject-type 0 relation-eid resource-type 0] - [subject-type max-entid relation-eid resource-type max-entid]))))) + ;; nil-padded to full tuple arity: DataScript sorts vectors length-first. + (->> (ds/seek-datoms db :avet + forward-partial-relationship-attr + [subject-type relation-eid nil nil nil]) + (take-while (fn [datom] + (and (= forward-partial-relationship-attr (:a datom)) + (let [v (:v datom)] + (and (= subject-type (nth v 0)) + (= relation-eid (nth v 1))))))) + (count))))) (defn write-schema! - [conn schema-string] - (let [new-schema-map (parser/->eacl-schema (parser/parse-schema schema-string)) - _ (validate-schema-references new-schema-map) - db (ds/db conn) - existing-schema (read-schema db) - deltas (compare-schema existing-schema new-schema-map) - {:keys [relations permissions]} deltas - relation-retractions (:retractions relations) - permission-retractions (:retractions permissions)] - (doseq [rel relation-retractions] - (let [cnt (count-relationships-using-relation db rel)] - (when (pos? cnt) - (throw (ex-info (str "Cannot delete relation " (:eacl.relation/relation-name rel) - " because it is used by " cnt " relationships.") - {:relation rel :count cnt}))))) - (ds/transact! conn - (concat - (:additions relations) - (:additions permissions) - (for [rel relation-retractions - :let [eid (ds/entid db [:eacl/id (:eacl/id rel)])] - :when eid] - [:db/retractEntity eid]) - (for [perm permission-retractions - :let [eid (ds/entid db [:eacl/id (:eacl/id perm)])] - :when eid] - [:db/retractEntity eid]) - [{:eacl/id "schema-string" - :eacl/schema-string schema-string}])) - deltas)) + "Parses, validates, diffs and transacts a SpiceDB schema string. + Throws :eacl.schema/parse-error on unparseable input (a failed parse must + never retract the stored schema) and :eacl.schema/empty-schema-guard when the + new schema has zero definitions while a non-empty schema is stored; pass + {:allow-empty-schema? true} to wipe intentionally." + ([conn schema-string] + (write-schema! conn schema-string {})) + ([conn schema-string {:keys [allow-empty-schema?]}] + (let [new-schema-map (parser/->eacl-schema (parser/parse-schema schema-string)) + _ (validate-schema-references new-schema-map) + db (ds/db conn) + existing-schema (read-schema db) + _ (when (and (empty? (:definitions new-schema-map)) + (not allow-empty-schema?) + (or (seq (:relations existing-schema)) + (seq (:permissions existing-schema)))) + (throw (ex-info (str "Refusing to replace a non-empty schema with zero definitions." + " Pass {:allow-empty-schema? true} to write-schema! if this is intentional.") + {:type :eacl.schema/empty-schema-guard + :existing {:relations (count (:relations existing-schema)) + :permissions (count (:permissions existing-schema))}}))) + deltas (compare-schema existing-schema new-schema-map) + {:keys [relations permissions]} deltas + relation-retractions (:retractions relations) + permission-retractions (:retractions permissions)] + (doseq [rel relation-retractions] + (let [cnt (count-relationships-using-relation db rel)] + (when (pos? cnt) + (throw (ex-info (str "Cannot delete relation " (:eacl.relation/relation-name rel) + " because it is used by " cnt " relationships.") + {:relation rel :count cnt}))))) + (ds/transact! conn + (concat + (:additions relations) + (:additions permissions) + (for [rel relation-retractions + :let [eid (ds/entid db [:eacl/id (:eacl/id rel)])] + :when eid] + [:db/retractEntity eid]) + (for [perm permission-retractions + :let [eid (ds/entid db [:eacl/id (:eacl/id perm)])] + :when eid] + [:db/retractEntity eid]) + [{:eacl/id "schema-string" + :eacl/schema-string schema-string}])) + deltas))) diff --git a/modules/eacl-datomic/src/eacl/datomic/core.clj b/modules/eacl-datomic/src/eacl/datomic/core.clj index eee40c7a7..9c37c83c3 100644 --- a/modules/eacl-datomic/src/eacl/datomic/core.clj +++ b/modules/eacl-datomic/src/eacl/datomic/core.clj @@ -30,10 +30,10 @@ (cond-> cursor (:e cursor) (update :e #(entid->object-id db %)) (:p cursor) (update :p - (fn [p] - (into {} - (map (fn [[k v]] [k (entid->object-id db v)])) - p)))) + (fn [p] + (into {} + (map (fn [[k v]] [k (entid->object-id db v)])) + p)))) :else (cond (:resource cursor) (S/transform [:resource :id] #(entid->object-id db %) cursor) @@ -52,10 +52,10 @@ (cond-> cursor (:e cursor) (update :e #(object-id->entid db %)) (:p cursor) (update :p - (fn [p] - (into {} - (map (fn [[k v]] [k (object-id->entid db v)])) - p)))) + (fn [p] + (into {} + (map (fn [[k v]] [k (object-id->entid db v)])) + p)))) :else (cond (:resource cursor) (S/transform [:resource :id] #(object-id->entid db %) cursor) @@ -91,37 +91,52 @@ subject-id (assoc :subject/id subject-eid) resource-id (assoc :resource/id resource-eid)) filters'' (S/transform [:cursor] - (fn [token-or-cursor] - (some->> (token->cursor token-or-cursor) - (spice-cursor->internal db opts))) - filters') + (fn [token-or-cursor] + (some->> (token->cursor token-or-cursor opts) + (spice-cursor->internal db opts))) + filters') result (impl/read-relationships db filters'')] (-> result ((fn [page] (S/transform [:data S/ALL] - #(relationship->spice db opts %) - page))) + #(relationship->spice db opts %) + page))) ((fn [page] (S/transform [:cursor] - (fn [internal-cursor] - (some->> (internal-cursor->spice db opts internal-cursor) - cursor->token)) - page)))))))) + (fn [internal-cursor] + (some-> (internal-cursor->spice db opts internal-cursor) + (cursor->token opts))) + page)))))))) + +(defn- resolve-existing-object + "Resolves an external spice object to its internal eid, verifying the entity + actually exists (datom presence - d/entid passes unallocated numeric eids + through unchanged). Throws :eacl/unknown-object otherwise (audit 11)." + [db object-id->entid {:keys [type id] :as obj}] + (let [eid (when (some? id) (object-id->entid db id))] + (if (and eid (seq (d/datoms db :eavt eid))) + (assoc obj :id eid) + (throw (ex-info (str "Unknown object: " (pr-str type) " with id " (pr-str id) " does not exist.") + {:type :eacl/unknown-object + :object {:type type :id id}}))))) (defn spice-relationship->internal - [db {:keys [spice-object->internal]} {:keys [subject relation resource]}] - {:subject (spice-object->internal db subject) + "Resolves both relationship endpoints to existing internal eids. + Throws :eacl/unknown-object rather than letting nils or ghost ids reach + tx-data (raw :db.error/not-an-entity) or silently no-op." + [db {:keys [object-id->entid]} {:keys [subject relation resource]}] + {:subject (resolve-existing-object db object-id->entid subject) :relation relation - :resource (spice-object->internal db resource)}) + :resource (resolve-existing-object db object-id->entid resource)}) (defn spiceomic-write-relationships! [conn opts updates] (let [db (d/db conn) tx-data (->> updates - (S/transform [S/ALL :relationship] - #(spice-relationship->internal db opts %)) - (mapcat #(impl/tx-update-relationship db %)) - (remove nil?)) + (S/transform [S/ALL :relationship] + #(spice-relationship->internal db opts %)) + (mapcat #(impl/tx-update-relationship db %)) + (remove nil?)) {:keys [db-after]} @(d/transact conn tx-data) basis (d/basis-t db-after)] {:zed/token (str basis)})) @@ -134,8 +149,10 @@ (defn spiceomic-can? [db {:keys [object->entid]} subject permission resource consistency] - (assert (= consistency/fully-consistent consistency) - "EACL only supports consistency/fully-consistent at this time.") + (when-not (= consistency/fully-consistent consistency) + (throw (ex-info "EACL only supports consistency/fully-consistent at this time." + {:type :eacl/unsupported-consistency + :consistency consistency}))) (let [subject-type (:type subject) subject-eid (object->entid db subject) resource-type (:type resource) @@ -143,9 +160,9 @@ (if-not (and subject-eid resource-eid) false (impl/can? db - (spice-object subject-type subject-eid) - permission - (spice-object resource-type resource-eid))))) + (spice-object subject-type subject-eid) + permission + (spice-object resource-type resource-eid))))) (defn spiceomic-lookup-resources [db @@ -158,24 +175,23 @@ {:as query :keys [subject]}] (log/debug 'spiceomic-lookup-resources 'query query) (let [internal-subject (spice-object->internal db subject)] - (assert (:id internal-subject) - (str "subject " (pr-str subject) - " passed to lookup-resources does not exist with ident " - (object-id->ident (:id subject)))) - (->> query - (S/setval [:subject] internal-subject) - (S/transform [:cursor] - (fn [token-or-cursor] - (some->> (token->cursor token-or-cursor) - (spice-cursor->internal db opts)))) - (impl/lookup-resources db) - (S/transform [:data S/ALL] - (fn [{:keys [type id]}] - (spice-object type (entid->object-id db id)))) - (S/transform [:cursor] - (fn [internal-cursor] - (some->> (internal-cursor->spice db opts internal-cursor) - cursor->token)))))) + (if (nil? (:id internal-subject)) + ;; Unknown subjects match nothing (SpiceDB-consistent; can? is false). + {:data [] :cursor nil} + (->> query + (S/setval [:subject] internal-subject) + (S/transform [:cursor] + (fn [token-or-cursor] + (some->> (token->cursor token-or-cursor opts) + (spice-cursor->internal db opts)))) + (impl/lookup-resources db) + (S/transform [:data S/ALL] + (fn [{:keys [type id]}] + (spice-object type (entid->object-id db id)))) + (S/transform [:cursor] + (fn [internal-cursor] + (some-> (internal-cursor->spice db opts internal-cursor) + (cursor->token opts)))))))) (defn spiceomic-count-resources [db @@ -185,22 +201,20 @@ internal-cursor->spice]} {:as query :keys [subject]}] (let [subject-ent (spice-object->internal db subject)] - (assert (:id subject-ent) - (str "subject passed to count-resources does not exist: " (pr-str subject))) - (assert (= (:type subject-ent) (:type subject)) - (str "count-resources: subject type passed does not match entity: " - (pr-str subject))) - (->> query - (S/setval [:subject] subject-ent) - (S/transform [:cursor] - (fn [token-or-cursor] - (some->> (token->cursor token-or-cursor) - (spice-cursor->internal db opts)))) - (impl/count-resources db) - (S/transform [:cursor] - (fn [internal-cursor] - (some->> (internal-cursor->spice db opts internal-cursor) - cursor->token)))))) + (if (nil? (:id subject-ent)) + ;; Unknown subjects match nothing (SpiceDB-consistent; can? is false). + {:count 0 :limit (:limit query -1) :cursor nil} + (->> query + (S/setval [:subject] subject-ent) + (S/transform [:cursor] + (fn [token-or-cursor] + (some->> (token->cursor token-or-cursor opts) + (spice-cursor->internal db opts)))) + (impl/count-resources db) + (S/transform [:cursor] + (fn [internal-cursor] + (some-> (internal-cursor->spice db opts internal-cursor) + (cursor->token opts)))))))) (defn spiceomic-lookup-subjects [db @@ -211,19 +225,19 @@ internal-cursor->spice]} query] (->> query - (S/transform [:resource] #(spice-object->internal db %)) - (S/transform [:cursor] - (fn [token-or-cursor] - (some->> (token->cursor token-or-cursor) - (spice-cursor->internal db opts)))) - (impl/lookup-subjects db) - (S/transform [:data S/ALL] - (fn [{:keys [type id]}] - (spice-object type (entid->object-id db id)))) - (S/transform [:cursor] - (fn [internal-cursor] - (some->> (internal-cursor->spice db opts internal-cursor) - cursor->token))))) + (S/transform [:resource] #(spice-object->internal db %)) + (S/transform [:cursor] + (fn [token-or-cursor] + (some->> (token->cursor token-or-cursor opts) + (spice-cursor->internal db opts)))) + (impl/lookup-subjects db) + (S/transform [:data S/ALL] + (fn [{:keys [type id]}] + (spice-object type (entid->object-id db id)))) + (S/transform [:cursor] + (fn [internal-cursor] + (some-> (internal-cursor->spice db opts internal-cursor) + (cursor->token opts)))))) (defn spiceomic-count-subjects [db @@ -233,16 +247,16 @@ internal-cursor->spice]} query] (->> query - (S/transform [:resource] #(spice-object->internal db %)) - (S/transform [:cursor] - (fn [token-or-cursor] - (some->> (token->cursor token-or-cursor) - (spice-cursor->internal db opts)))) - (impl/count-subjects db) - (S/transform [:cursor] - (fn [internal-cursor] - (some->> (internal-cursor->spice db opts internal-cursor) - cursor->token))))) + (S/transform [:resource] #(spice-object->internal db %)) + (S/transform [:cursor] + (fn [token-or-cursor] + (some->> (token->cursor token-or-cursor opts) + (spice-cursor->internal db opts)))) + (impl/count-subjects db) + (S/transform [:cursor] + (fn [internal-cursor] + (some-> (internal-cursor->spice db opts internal-cursor) + (cursor->token opts)))))) (defrecord Spiceomic [conn opts] IAuthorization @@ -254,7 +268,7 @@ (can? [_ {:keys [subject permission resource consistency]}] (spiceomic-can? (d/db conn) opts subject permission resource - (or consistency consistency/fully-consistent))) + (or consistency consistency/fully-consistent))) (read-schema [_] (schema/read-schema (d/db conn))) @@ -270,41 +284,41 @@ (write-relationship! [_ operation subject relation resource] (spiceomic-write-relationships! conn opts - [(->RelationshipUpdate operation - (->Relationship subject relation resource))])) + [(->RelationshipUpdate operation + (->Relationship subject relation resource))])) (write-relationship! [_ {:as demand :keys [operation subject relation resource]}] (spiceomic-write-relationships! conn opts - [(->RelationshipUpdate operation - (->Relationship subject relation resource))])) + [(->RelationshipUpdate operation + (->Relationship subject relation resource))])) (create-relationships! [_ relationships] (spiceomic-write-relationships! conn opts - (for [rel relationships] - (->RelationshipUpdate :create rel)))) + (for [rel relationships] + (->RelationshipUpdate :create rel)))) (create-relationship! [_ relationship] (spiceomic-write-relationships! conn opts - [(->RelationshipUpdate :create relationship)])) + [(->RelationshipUpdate :create relationship)])) (create-relationship! [_ subject relation resource] (spiceomic-write-relationships! conn opts - [(->RelationshipUpdate :create (->Relationship subject relation resource))])) + [(->RelationshipUpdate :create (->Relationship subject relation resource))])) (delete-relationships! [_ relationships] (spiceomic-write-relationships! conn opts - (for [rel (relationship-seq relationships)] - (->RelationshipUpdate :delete rel)))) + (for [rel (relationship-seq relationships)] + (->RelationshipUpdate :delete rel)))) (delete-relationship! [_ {:as relationship :keys [subject relation resource]}] (spiceomic-write-relationships! conn opts - [(->RelationshipUpdate :delete - (->Relationship subject relation resource))])) + [(->RelationshipUpdate :delete + (->Relationship subject relation resource))])) (delete-relationship! [_ subject relation resource] (spiceomic-write-relationships! conn opts - [(->RelationshipUpdate :delete - (->Relationship subject relation resource))])) + [(->RelationshipUpdate :delete + (->Relationship subject relation resource))])) (lookup-resources [_ query] (spiceomic-lookup-resources (d/db conn) opts query)) @@ -319,34 +333,69 @@ (spiceomic-count-subjects (d/db conn) opts query)) (expand-permission-tree [_ _] - (throw (Exception. "not impl.")))) + (throw (ex-info "expand-permission-tree is not implemented yet." + {:type :eacl/not-implemented + :method (quote expand-permission-tree)})))) + +(def ^:private known-client-opt-keys + #{:entid->object-id + :entity->object-id + :object-id->ident + :internal-cursor->spice + :spice-cursor->internal + :cursor-ttl-seconds}) (defn make-client + "Builds an IAuthorization client over a Datomic conn. + + Options (unknown keys throw :eacl/invalid-config - a silently ignored key + means silently wrong ID coercion, audit 5): + - :entid->object-id (fn [db eid] external-id) - canonical, as documented in the README. + - :entity->object-id (fn [entity] external-id) - deprecated alias; do not combine with the above. + - :object-id->ident (fn [external-id] ident-resolvable-by-d-entid). Default: [:eacl/id id]. + - :cursor-ttl-seconds - optional cursor token expiry; default nil (tokens never expire). + - :internal-cursor->spice / :spice-cursor->internal - advanced cursor coercion overrides." [conn - {:keys [entity->object-id + {:as config-opts + :keys [entid->object-id + entity->object-id object-id->ident internal-cursor->spice - spice-cursor->internal] - :or {entity->object-id (fn [ent] (:eacl/id ent)) - object-id->ident (fn [obj-id] [:eacl/id obj-id]) + spice-cursor->internal + cursor-ttl-seconds] + :or {object-id->ident (fn [obj-id] [:eacl/id obj-id]) internal-cursor->spice default-internal-cursor->spice spice-cursor->internal default-spice-cursor->internal}}] - (assert (fn? object-id->ident) - "EACL Config Error: object-id->ident fn is required to coerce a Spice Object ID to a Datomic ident that can be resolved by d/entid.") - (let [object-id->entid (fn [db object-id] + (when-let [unknown-keys (seq (remove known-client-opt-keys (keys config-opts)))] + (throw (ex-info (str "EACL Config Error: unknown make-client option(s) " (pr-str (vec unknown-keys)) + ". Known options: " (pr-str (vec (sort known-client-opt-keys))) ".") + {:type :eacl/invalid-config + :unknown-keys (vec unknown-keys) + :known-keys known-client-opt-keys}))) + (when (and entid->object-id entity->object-id) + (throw (ex-info "EACL Config Error: supply only one of :entid->object-id (canonical) or :entity->object-id (deprecated alias)." + {:type :eacl/invalid-config + :conflicting-keys [:entid->object-id :entity->object-id]}))) + (when-not (fn? object-id->ident) + (throw (ex-info "EACL Config Error: object-id->ident must be a fn that coerces a Spice Object ID to a Datomic ident resolvable by d/entid." + {:type :eacl/invalid-config + :key :object-id->ident}))) + (let [entid->object-id (or entid->object-id + (when entity->object-id + (fn [db eid] (entity->object-id (d/entity db eid)))) + (fn [db eid] (:eacl/id (d/entity db eid)))) + object-id->entid (fn [db object-id] (d/entid db (object-id->ident object-id))) - entid->object-id (fn [db eid] - (entity->object-id (d/entity db eid))) opts {:object-id->ident object-id->ident :entid->object-id entid->object-id - :entity->object-id entity->object-id :object-id->entid object-id->entid + :cursor-ttl-seconds cursor-ttl-seconds :object->entid (fn [db {:keys [id]}] (object-id->entid db id)) :internal-object->spice (fn [db {:keys [type id]}] (spice-object type (entid->object-id db id))) :spice-object->internal (fn [db obj] - (update obj :id #(object-id->entid db %))) + (update obj :id #(when (some? %) (object-id->entid db %)))) :internal-cursor->spice internal-cursor->spice :spice-cursor->internal spice-cursor->internal}] (->Spiceomic conn opts))) diff --git a/modules/eacl-datomic/src/eacl/datomic/impl.clj b/modules/eacl-datomic/src/eacl/datomic/impl.clj index 6cbe09de9..84da6814c 100644 --- a/modules/eacl-datomic/src/eacl/datomic/impl.clj +++ b/modules/eacl-datomic/src/eacl/datomic/impl.clj @@ -35,12 +35,42 @@ true (throw (Exception. "Unauthorized")))) +(defn- unknown-object! + [object-id] + (throw (ex-info (str "Unknown object: " (pr-str object-id) " does not resolve to an existing entity." + " Pass {:allow-tempids? true} to tx-relationship for same-transaction tempids.") + {:type :eacl/unknown-object + :object-id object-id}))) + (defn- object-id->eid-or-tempid - [db object-id] + "Resolves an object id to an existing eid. Unresolvable ids throw + :eacl/unknown-object unless :allow-tempids? is set, in which case strings, + negative longs and datomic.db.DbId values pass through as tempids for + same-transaction entity+relationship creation. Silent tempid pass-through + minted ghost entities on typo'd ids (audit 12). Positive numeric eids are + verified via datom presence." + [db object-id {:keys [allow-tempids?]}] (cond - (number? object-id) object-id - (string? object-id) (or (d/entid db [:eacl/id object-id]) object-id) - :else (or (d/entid db object-id) object-id))) + (number? object-id) + (cond + (seq (d/datoms db :eavt object-id)) object-id + (and allow-tempids? (neg? object-id)) object-id + :else (unknown-object! object-id)) + + (string? object-id) + (or (d/entid db [:eacl/id object-id]) + (if allow-tempids? + object-id + (unknown-object! object-id))) + + (instance? datomic.db.DbId object-id) + (if allow-tempids? + object-id + (unknown-object! object-id)) + + :else + (or (d/entid db object-id) + (unknown-object! object-id)))) (defn- internal-id [db value] @@ -58,11 +88,11 @@ db resource-type relation-name subject-type)) (defn- resolve-relationship - [db {:keys [subject relation resource]}] + [db {:keys [subject relation resource]} opts] (let [subject-type (:type subject) - subject-eid (object-id->eid-or-tempid db (:id subject)) + subject-eid (object-id->eid-or-tempid db (:id subject) opts) resource-type (:type resource) - resource-eid (object-id->eid-or-tempid db (:id resource)) + resource-eid (object-id->eid-or-tempid db (:id resource) opts) relation-eid (find-relation-eid db resource-type relation subject-type)] (when-not relation-eid (throw @@ -123,8 +153,12 @@ (defn find-one-relationship-id "Returns the resolved tuple identity for an existing relationship, or nil." [db relationship] - (let [resolved (resolve-relationship db relationship)] - (when (relationship-exists? db resolved) + (let [resolved (try + (resolve-relationship db relationship {}) + (catch clojure.lang.ExceptionInfo e + (when-not (= :eacl/unknown-object (:type (ex-data e))) + (throw e))))] + (when (and resolved (relationship-exists? db resolved)) resolved))) (defn- find-relations @@ -323,13 +357,15 @@ ([db subject relation resource] (tx-relationship db (eacl/->Relationship subject relation resource))) ([db relationship] - (add-relationship-txes (resolve-relationship db relationship)))) + (tx-relationship db relationship {})) + ([db relationship opts] + (add-relationship-txes (resolve-relationship db relationship opts)))) (defn tx-update-relationship "Relationship writes are implemented against v7 forward/reverse tuple indexes. :touch is idempotent." [db {:keys [operation relationship]}] - (let [resolved (resolve-relationship db relationship) + (let [resolved (resolve-relationship db relationship {}) exists? (relationship-exists? db resolved)] (case operation :touch diff --git a/modules/eacl-datomic/src/eacl/datomic/impl/base.clj b/modules/eacl-datomic/src/eacl/datomic/impl/base.clj index f4944d9f3..4d3b5a812 100644 --- a/modules/eacl-datomic/src/eacl/datomic/impl/base.clj +++ b/modules/eacl-datomic/src/eacl/datomic/impl/base.clj @@ -9,17 +9,8 @@ (def ->permission-id model/->permission-id) (def Permission model/Permission) -(defn Relationship - "A Relationship between a subject and a resource via Relation. Copied from core2." - [subject relation-name resource] - ; :pre can be expensive. - {:pre [(:id subject) - (:type subject) - (keyword? relation-name) - (:id resource) - (:type resource)]} - {:eacl.relationship/resource-type (:type resource) - :eacl.relationship/resource (:id resource) - :eacl.relationship/relation-name relation-name - :eacl.relationship/subject-type (:type subject) - :eacl.relationship/subject (:id subject)}) +;; NOTE: the v6-era `Relationship` fn (emitting :eacl.relationship/* entity +;; attrs) was removed: those attributes do not exist in the v7 Datomic schema, +;; so any transact of its output failed with :db.error/not-an-entity. Use +;; eacl.datomic.impl/Relationship (data) + eacl.datomic.impl/tx-relationship +;; (tx-data) instead. diff --git a/modules/eacl-datomic/src/eacl/datomic/impl/datalog.clj b/modules/eacl-datomic/src/eacl/datomic/impl/datalog.clj deleted file mode 100644 index 128fbcf10..000000000 --- a/modules/eacl-datomic/src/eacl/datomic/impl/datalog.clj +++ /dev/null @@ -1,153 +0,0 @@ -(ns eacl.datomic.impl.datalog - "Optimized EACL implementation with performance improvements" - (:require - [datomic.api :as d] - [eacl.core :as proto :refer [spice-object]] - ;[eacl.datomic.impl.base :as base] - [eacl.datomic.rules.optimized :as rules])) - -(defn lookup-subjects - "Optimized version of lookup-subjects" - [db - {:as filters - resource :resource - permission :permission - subject-type :subject/type - _subject-relation :subject/relation ; not currently supported. - limit :limit - offset :offset}] - {:pre [(:type resource) (:id resource)]} - (let [{resource-type :type - resource-id :id} resource - - resource-eid (d/entid db resource-id)] - ; Q: can we support dynamic object type resolution? - (assert resource-eid (str "lookup-subjects (object->entid " (pr-str resource) ") must resolve to a valid Datomic entid.")) - ; todo configurable type resolution. - ;(assert (= resource-type (:eacl/type resource-ent)) (str "Resource type does not match " resource-type ".")) - (let [subject-types+eids (->> (d/q '[:find ?subject-type ?subject - :in $ % ?subject-type ?permission ?resource-type ?resource-eid - :where - (has-permission ?subject-type ?subject ?permission ?resource-type ?resource-eid) - [(not= ?subject ?resource-eid)]] - db - rules/rules-lookup-subjects - subject-type - permission - resource-type - resource-eid)) - paginated-types+eids (cond->> subject-types+eids ; better name. - offset (drop offset) - limit (take limit)) - formatted (->> paginated-types+eids - (map (fn [[type id]] - (spice-object type id))))] - ;(prn 'paginated-types+eids paginated-types+eids) - ;(prn 'formatted formatted) - ; todo: subjects cursor is WIP. We still support offset & limit. - {:data formatted - :cursor nil}))) - -(defn can? - "can? uses recursive Datalog rules. Seems to be fast enough." - [db subject permission resource] - {:pre [subject - resource - (keyword? permission) - (:id subject) - (:type subject) - - (:id resource) - (:type resource)]} - (let [; todo hoist. - {subject-type :type - subject-ident :id} subject - - {resource-type :type - resource-ident :id} resource - - ; todo assert resource-ident - - ; do we need the d/entid here? - subject-eid (d/entid db subject-ident) - resource-eid (d/entid db resource-ident)] - (if-not (and subject-eid resource-eid) ; duplicated in Spiceomic. - false - (->> (d/q '[:find ?subject . - :in $ % ?subject-type ?subject ?perm ?resource-type ?resource - :where - (has-permission ?subject-type ?subject ?perm ?resource-type ?resource)] - db - rules/check-permission-rules - subject-type - subject-eid - permission - resource-type - resource-eid) - (boolean))))) - -(defn lookup-resources - ; outdated. - "Slow version of lookup-resources that reuses check-permission-rules. - Does not support cursor, only limit & offset." - [db {:as _query - subject :subject - permission :permission - resource-type :resource/type - limit :limit - cursor :cursor}] - {:pre [(:type subject) (:id subject)]} - (let [{subject-type :type - subject-ident :id} subject - - {cursor-path :path-index - cursor-resource :resource} cursor - - {cursor-resource-type :type - cursor-resource-eid :id} cursor-resource - - subject-eid (d/entid db subject-ident)] - - (assert subject-eid (pr-str "lookup-resources requires a valid subject :id that resolves to an eid via d/entid: " subject-ident ".")) - (let [resource-types+eids (->> (d/q '[:find ?resource-type ?resource - :in $ % ?subject-type ?subject-eid ?permission ?resource-type - :where - ;(has-permission ?subject-type ?subject-eid ?permission ?resource-type ?resource) - (has-permission ?subject-type ?subject-eid ?permission ?resource-type ?resource) - [(not= ?resource ?subject-eid)]] ; do we still need this? - db - rules/check-permission-rules ; rules-lookup-resources - subject-type - subject-eid - permission - resource-type)) - sorted-by-type+eid (sort resource-types+eids) - offsetted-results (if (and cursor-resource-type cursor-resource-eid) - (->> sorted-by-type+eid - (drop-while (fn [[resource-type resource-eid]] - ; design decision on <= vs < is to skip the matching value until next cursor is smarter. - (<= resource-eid cursor-resource-eid)))) - sorted-by-type+eid) - - paginated-types+eids (cond->> offsetted-results ; resource-types+eids - ; offset (drop offset) ; cursor should take care of this. - limit (take limit)) - ;sorted-by-type+eid (sort paginated-types+eids) - formatted (->> paginated-types+eids ; sorted-by-type+eid - (map (fn [[type eid]] (spice-object type eid)))) - last-result (when (seq formatted) (last formatted))] ; Fix: only get last when there are results - {:cursor (when last-result {:resource last-result}) ; Fix: only create cursor when there's a last result - :limit limit - :data formatted}))) - -(defn count-resources - "Temporary. Just calls lookup-resources. - Super inefficient due to the sort in lookup-resources, which is not required. - Any complete count will need to materialize full index. - Note that count-resources supports cursor, so if you count from a :cursor, - it will only return the results after the cursor." - [db query] - (->> (assoc query :limit Long/MAX_VALUE) - (lookup-resources db) - (:data) - (count))) \ No newline at end of file diff --git a/modules/eacl-datomic/src/eacl/datomic/impl/indexed.clj b/modules/eacl-datomic/src/eacl/datomic/impl/indexed.clj index f1128d2d7..e2d525b14 100644 --- a/modules/eacl-datomic/src/eacl/datomic/impl/indexed.clj +++ b/modules/eacl-datomic/src/eacl/datomic/impl/indexed.clj @@ -46,15 +46,26 @@ (map (fn [[_ _ v]] (nth v 3)))))) (defn relation-datoms - "Returns relation datoms for the exact resource/relation name pair." + "Returns relation datoms for the exact resource/relation name pair, + for ANY subject-type keyword. + + Implemented as a seek + prefix take-while rather than a bounded + d/index-range: a keyword-sentinel range like [.. :a]..[.. :z] silently + misses subject types that collate outside it (uppercase-initial, + z-prefixed, and all namespaced keywords), which made those relations + invisible to permission evaluation (audit 2). The attr-eid guard is + mandatory - seek-datoms iterates past the attribute's index segment." [db resource-type relation-name] (if (and resource-type relation-name) - (let [start-tuple [resource-type relation-name :a] - end-tuple [resource-type relation-name :z]] - (d/index-range db - :eacl.relation/resource-type+relation-name+subject-type - start-tuple - end-tuple)) + (let [attr-eid (d/entid db :eacl.relation/resource-type+relation-name+subject-type)] + (->> (d/seek-datoms db :avet + :eacl.relation/resource-type+relation-name+subject-type + [resource-type relation-name]) + (take-while (fn [datom] + (and (= attr-eid (:a datom)) + (let [v (:v datom)] + (and (= resource-type (nth v 0)) + (= relation-name (nth v 1))))))))) [])) (defn find-relation-def @@ -83,6 +94,81 @@ (defn evict-permission-paths-cache! [] (engine/evict-permission-paths-cache! permission-paths-cache)) +;; --- Schema-history digest cache stamp (audit 3 / D8) ---------------------- +;; +;; Coverage invariant: every attribute that permission-path computation reads +;; MUST be a component of one of the composite tuples digested below. Datomic +;; rewrites a composite tuple datom in the same transaction as ANY component +;; change, and retractEntity retracts it, so the tuple histories are a complete +;; record of path-relevant schema mutations. Any schema mutation - write-schema!, +;; programmatic transaction, retraction, or excision - changes the digest, on +;; every peer, for d/as-of views, with no writer-side signal. + +(def ^:private schema-digest-attrs + [:eacl.relation/resource-type+relation-name+subject-type + :eacl.permission/resource-type+source-relation-name+target-type+target-name+permission-name]) + +(defonce ^:private schema-scope-memo + ;; Keyed by the db value itself: Datomic Db equality is value- and + ;; content-based (pinned by tests), so this can only unify db values whose + ;; visible histories - and therefore digests - are identical. Weak keys + ;; release with the db value. Sentinel (uncached) scopes are never stored. + (java.util.Collections/synchronizedMap (java.util.WeakHashMap.))) + +(defn- classified-view + "Positively classifies a db value: :plain, :as-of, or nil for anything the + digest must not be shared for. d/filter views are excluded because their + predicates are arbitrary functions (possibly impure or time-dependent), so a + digest of their filtered history is not trustworthy as a shared cache key; + d/since views hide old schema; history views are not queryable schema states." + [db] + (cond + (d/is-history db) nil + (d/is-filtered db) nil + (some? (d/since-t db)) nil + (some? (d/as-of-t db)) :as-of + :else :plain)) + +(defn- schema-history-digest + "128-bit hex digest (SHA-256 truncated; FIPS-safe) folded in index order over + the history datoms of the schema composite tuple attrs, filtered to the db's + visible basis. NOTE: d/basis-t of an as-of view returns the UNDERLYING basis + (pinned by tests), so the visibility filter must prefer d/as-of-t." + [db] + (let [md (java.security.MessageDigest/getInstance "SHA-256") + limit-t (or (d/as-of-t db) (d/basis-t db)) + hist (d/history db)] + (doseq [attr schema-digest-attrs + datom (d/datoms hist :aevt attr) + :let [t (d/tx->t (:tx datom))] + :when (<= t limit-t)] + (.update md (.getBytes ^String (pr-str [(:e datom) (:v datom) t (:added datom)]) "UTF-8"))) + (format "%032x" (java.math.BigInteger. 1 (java.util.Arrays/copyOf (.digest md) 16))))) + +(defn schema-cache-scope + "Returns [database-id schema-history-digest] for positively classified + plain/as-of db values, or a fresh unique sentinel for anything else and for + ANY failure. Sentinel scopes make every cache key unique: every failure mode + degrades to recomputation from the queried db value - never staleness." + [db] + (or (.get ^java.util.Map schema-scope-memo db) + (let [scope (try + (when (classified-view db) + [(str (.id db)) (schema-history-digest db)]) + (catch Throwable _ nil))] + (if scope + (do (.put ^java.util.Map schema-scope-memo db scope) + scope) + [::uncached (Object.)])))) + +(defn schema-basis-digest + "The schema-history digest for this db value, or nil when the view cannot be + cached (see schema-cache-scope)." + [db] + (let [scope (schema-cache-scope db)] + (when-not (= ::uncached (first scope)) + (second scope)))) + (defn direct-match-datoms-in-relationship-index [db subject-type subject-eid relation-eid resource-type resource-eid] (d/datoms db @@ -94,7 +180,10 @@ (defn indexed-backend [db] {:cache-stamp (fn [] - (System/identityHashCode db)) + ;; Content-derived schema scope (audit 3): identityHashCode + ;; keyed one cache entry per db OBJECT (a near-always-miss + ;; cache) and could collide across GC address reuse. + (schema-cache-scope db)) :relation-defs (fn [resource-type relation-name] (mapv (fn [datom] {:relation-id (:e datom) @@ -185,8 +274,10 @@ (update query :subject #(internalize-anchor db %)))) (defn lookup-subjects + "Unknown/missing resources return an empty page (SpiceDB-consistent), + matching can? -> false; assertion-based rejection disappears under + *assert* false and crashed with an untyped AssertionError." [db query] - {:pre [(:type (:resource query)) (:id (:resource query))]} (engine/lookup (indexed-backend db) engine/reverse-direction diff --git a/modules/eacl-datomic/src/eacl/datomic/rules.clj b/modules/eacl-datomic/src/eacl/datomic/rules.clj deleted file mode 100644 index 93cdd5738..000000000 --- a/modules/eacl-datomic/src/eacl/datomic/rules.clj +++ /dev/null @@ -1,551 +0,0 @@ -(ns eacl.datomic.rules) - -;(def check-permission-rules -; "Can only be used for can? where type + id of both subject & resource object are provided." -; '[;; Reachability rules to traverse relationships: -; [(reachable ?resource ?subject) -; [(tuple ?resource ?subject) ?resource+subject] -; [?relationship :eacl.relationship/resource+subject ?resource+subject] -; -; [?relationship :eacl.relationship/resource ?resource] -; [?relationship :eacl.relationship/subject ?subject]] -; [(reachable ?resource ?subject) -; [?relationship :eacl.relationship/resource ?resource] -; [?relationship :eacl.relationship/subject ?mid] -; (reachable ?mid ?subject)] ; note inversion to traverse. -; -; ;; Direct permission check (copied and adapted from core2) -; [(has-permission ?subject ?permission-name ?resource) -; -; [(tuple ?resource ?relation-name-in-tuple ?subject) ?resource+rel-name+subject] -; [?relationship :eacl.relationship/resource+relation-name+subject ?resource+rel-name+subject] -; -; [?relationship :eacl.relationship/resource ?resource] ; subject has some relationship TO the resource -; [?relationship :eacl.relationship/relation-name ?relation-name-in-tuple] -; [?relationship :eacl.relationship/subject ?subject] ; subject of the relationship tuple -; -; ;; Permission definition: ?relation-name-in-perm-def grants ?permission-name on ?resource-type -; [(tuple ?resource-type ?relation-name-in-perm-def ?permission-name) ?res-type+relation+permission] -; [?perm-def :eacl.permission/resource-type+relation-name+permission-name ?res-type+relation+permission] -; -; [?perm-def :eacl.permission/resource-type ?resource-type] -; [?perm-def :eacl.permission/permission-name ?permission-name] -; [?perm-def :eacl.permission/relation-name ?relation-name-in-perm-def] ; THIS IS THE DIRECT GRANT -; -; ;; Match the relation name from the relationship tuple with the one in permission definition -; [(= ?relation-name-in-tuple ?relation-name-in-perm-def)] -; [(not= ?subject ?resource)]] -; -; ;; Indirect permission inheritance (copied from core2 - may need review/replacement with arrows) -; ;; This rule means: ?subject gets ?permission-name on ?resource if: -; ;; 1. A permission definition exists: for ?resource-type, ?relation-name-in-perm-def grants ?permission-name. -; ;; 2. ?resource has a relationship (as a subject of the tuple) via ?relation-name-in-perm-def to some ?target. -; ;; (e.g. doc D is "subject" of relation "group" to group G: D --group--> G) -; ;; 3. ?subject can "reach" that ?target (e.g. user U is member of group G). -; -; [(has-permission ?subject ?permission-name ?resource) -; ;; Permission definition -; [(tuple ?resource-type ?relation-name-in-perm-def ?permission-name) ?res-type+relation+permission] -; [?perm-def :eacl.permission/resource-type+relation-name+permission-name ?res-type+relation+permission] -; -; ; can these move down for speed? -; [?perm-def :eacl.permission/resource-type ?resource-type] -; [?perm-def :eacl.permission/permission-name ?permission-name] -; [?perm-def :eacl.permission/relation-name ?relation-name-in-perm-def] ; Direct relation specified in perm -; -; ;; Structural relationship: ?resource is linked to ?target via ?relation-name-in-perm-def -; [(tuple ?target ?relation-name-in-perm-def ?resource) ?target+relation+resource] -; [?structural-rel :eacl.relationship/resource+relation-name+subject ?target+relation+resource] -; -; [?structural-rel :eacl.relationship/subject ?resource] -; [?structural-rel :eacl.relationship/relation-name ?relation-name-in-perm-def] -; [?structural-rel :eacl.relationship/resource ?target] -; -; (reachable ?target ?subject) ; User must be able to reach the target of the structural relationship -; [(not= ?subject ?resource)]] -; -; ;; Arrow permission rule: ?subject gets ?perm-name-on-this-resource if it has ?perm-name-on-related on an intermediate resource -; ;; Example: User U gets :admin on VPC_X if VPC_X --:account--> ACC_Y and User U has :admin on ACC_Y. -; ;; MODIFIED based on user feedback: Rule now expects intermediate --via-relation-name--> this-resource -; ;; Example: User U gets :view on SERVER_X if ACC_Y --:account--> SERVER_X and User U has :admin on ACC_Y. -; [(has-permission ?subject ?perm-name-on-this-resource ?this-resource) -; ;; 1. Find an arrow permission definition for this-resource-type and perm-name-on-this-resource -; [(tuple ?this-resource-type -; ?via-relation-name -; ?perm-on-related -; ?perm-name-on-this-resource) ?res-type+relation+related-perm+permission] -; [?arrow-perm-def -; :eacl.arrow-permission/resource-type+source-relation-name+target-permission-name+permission-name -; ?res-type+relation+related-perm+permission] -; -; [?arrow-perm-def :eacl.arrow-permission/resource-type ?this-resource-type] -; [?arrow-perm-def :eacl.arrow-permission/permission-name ?perm-name-on-this-resource] -; [?arrow-perm-def :eacl.arrow-permission/source-relation-name ?via-relation-name] ; e.g., :account (the relation name specified in Permission) -; [?arrow-perm-def :eacl.arrow-permission/target-permission-name ?perm-on-related] ; e.g., :admin (on the intermediate/account) -; -; ;; 2. Find intermediate resource: ?intermediate-resource --via-relation-name--> ?this-resource -; [(tuple ?this-resource ?via-relation-name ?intermediate-resource) ?resource+relation+mid-resource] -; [?rel-linking-resources :eacl.relationship/resource+relation-name+subject ?resource+relation+mid-resource] -; [?rel-linking-resources :eacl.relationship/subject ?intermediate-resource] ; e.g., account is subject of tuple -; [?rel-linking-resources :eacl.relationship/relation-name ?via-relation-name] ; relation is :account -; [?rel-linking-resources :eacl.relationship/resource ?this-resource] ; e.g., server/vpc is resource of tuple -; -; ;; 3. Subject must have the target permission on the intermediate resource (recursive call) -; (has-permission ?subject ?perm-on-related ?intermediate-resource) -; [(not= ?subject ?this-resource)] ; Exclude self-references for safety -; ;; Ensure the intermediate resource is not the same as the subject to prevent some loops, -; ;; though main cycle prevention relies on data structure or more complex rule logic if needed. -; [(not= ?subject ?intermediate-resource)] -; ;; Ensure this-resource is not the same as intermediate for simple arrows like A -> B -; [(not= ?this-resource ?intermediate-resource)]]]) - -;(defn build-slow-rules [resource-type-attr] -; [;; Reachability rules to traverse relationships: -; '[(reachable ?resource ?subject) -; [(tuple ?resource ?subject) ?resource+subject] -; [?relationship :eacl.relationship/resource+subject ?resource+subject]] -; -; ;[?relationship :eacl.relationship/resource ?resource] -; ;[?relationship :eacl.relationship/subject ?subject]] -; '[(reachable ?resource ?subject) -; -; [(tuple ?resource ?mid) ?resource+mid] -; [?relationship :eacl.relationship/resource+subject ?resource+mid] ; range query? -; -; ; todo can we use tuple here? -; [?relationship :eacl.relationship/resource ?resource] -; [?relationship :eacl.relationship/subject ?mid] -; (reachable ?mid ?subject)] -; -; ;; Direct permission check (copied and adapted from core2) -; '[(has-permission ?subject ?permission-name ?resource) -; -; [(tuple ?resource ?relation-name-in-tuple ?subject) ?resource+rel-name+subject] -; [?relationship :eacl.relationship/resource+relation-name+subject ?resource+rel-name+subject] -; -; [?relationship :eacl.relationship/resource ?resource] ; subject has some relationship TO the resource -; [?relationship :eacl.relationship/relation-name ?relation-name-in-tuple] -; [?relationship :eacl.relationship/subject ?subject] ; subject of the relationship tuple -; -; ;; Permission definition: ?relation-name-in-perm-def grants ?permission-name on ?resource-type -; [(tuple ?resource-type ?relation-name-in-perm-def ?permission-name) ?res-type+relation+permission] -; [?perm-def :eacl.permission/resource-type+relation-name+permission-name ?res-type+relation+permission] -; -; [?perm-def :eacl.permission/resource-type ?resource-type] -; [?perm-def :eacl.permission/permission-name ?permission-name] -; [?perm-def :eacl.permission/relation-name ?relation-name-in-perm-def] ; THIS IS THE DIRECT GRANT -; -; ;; Match the relation name from the relationship tuple with the one in permission definition -; [(= ?relation-name-in-tuple ?relation-name-in-perm-def)] -; [(not= ?subject ?resource)] ; can we avoid this? -; [?resource :eacl/type ?resource-type]] ; this is super slow. different rules WIP. -; -; ;; Indirect permission inheritance (copied from core2 - may need review/replacement with arrows) -; ;; This rule means: ?subject gets ?permission-name on ?resource if: -; ;; 1. A permission definition exists: for ?resource-type, ?relation-name-in-perm-def grants ?permission-name. -; ;; 2. ?resource has a relationship (as a subject of the tuple) via ?relation-name-in-perm-def to some ?target. -; ;; (e.g. doc D is "subject" of relation "group" to group G: D --group--> G) -; ;; 3. ?subject can "reach" that ?target (e.g. user U is member of group G). -; (into -; ['(has-permission ?subject ?permission-name ?resource)] -; -; '[;; Permission definition -; [(tuple ?resource-type ?relation-name-in-perm-def ?permission-name) ?res-type+relation+permission] -; [?perm-def :eacl.permission/resource-type+relation-name+permission-name ?res-type+relation+permission] -; -; [?perm-def :eacl.permission/resource-type ?resource-type] -; [?perm-def :eacl.permission/permission-name ?permission-name] -; [?perm-def :eacl.permission/relation-name ?relation-name-in-perm-def] ; Direct relation specified in perm -; -; ;; Structural relationship: ?resource is linked to ?target via ?relation-name-in-perm-def -; [(tuple ?target ?relation-name-in-perm-def ?resource) ?target+relation+resource] -; [?structural-rel :eacl.relationship/resource+relation-name+subject ?target+relation+resource] -; -; [?structural-rel :eacl.relationship/subject ?resource] -; [?structural-rel :eacl.relationship/relation-name ?relation-name-in-perm-def] -; [?structural-rel :eacl.relationship/resource ?target] -; -; (reachable ?target ?subject) ; User must be able to reach the target of the structural relationship -; [(not= ?subject ?resource)] -; [?resource :eacl/type ?resource-type]]) -; -; ;; Arrow permission rule: ?subject gets ?perm-name-on-this-resource if it has ?perm-name-on-related on an intermediate resource -; ;; Example: User U gets :admin on VPC_X if VPC_X --:account--> ACC_Y and User U has :admin on ACC_Y. -; ;; MODIFIED based on user feedback: Rule now expects intermediate --via-relation-name--> this-resource -; ;; Example: User U gets :view on SERVER_X if ACC_Y --:account--> SERVER_X and User U has :admin on ACC_Y. -; '[(has-permission ?subject ?perm-name-on-this-resource ?this-resource) -; -; ;; 1. Find an arrow permission definition for this-resource-type and perm-name-on-this-resource -; [(tuple ?this-resource-type -; ?via-relation-name -; ?perm-on-related -; ?perm-name-on-this-resource) ?res-type+relation+related-perm+permission] -; [?arrow-perm-def -; :eacl.arrow-permission/resource-type+source-relation-name+target-permission-name+permission-name -; ?res-type+relation+related-perm+permission] -; -; ; can these move down for speed, or be decoupled in a 2nd phase? -; [?arrow-perm-def :eacl.arrow-permission/resource-type ?this-resource-type] -; [?arrow-perm-def :eacl.arrow-permission/permission-name ?perm-name-on-this-resource] -; [?arrow-perm-def :eacl.arrow-permission/source-relation-name ?via-relation-name] ; e.g., :account (the relation name specified in Permission) -; [?arrow-perm-def :eacl.arrow-permission/target-permission-name ?perm-on-related] ; e.g., :admin (on the intermediate/account) -; -; ;; 2. Find intermediate resource: ?intermediate-resource --via-relation-name--> ?this-resource -; [(tuple ?this-resource ?via-relation-name ?intermediate-resource) ?resource+relation+mid-resource] -; [?rel-linking-resources :eacl.relationship/resource+relation-name+subject ?resource+relation+mid-resource] -; -; [?rel-linking-resources :eacl.relationship/subject ?intermediate-resource] ; e.g., account is subject of tuple -; [?rel-linking-resources :eacl.relationship/relation-name ?via-relation-name] ; relation is :account -; [?rel-linking-resources :eacl.relationship/resource ?this-resource] ; e.g., server/vpc is resource of tuple -; -; ;; 3. Subject must have the target permission on the intermediate resource (recursive call) -; (has-permission ?subject ?perm-on-related ?intermediate-resource) -; [(not= ?subject ?this-resource)] ; Exclude self-references for safety -; ;; Ensure the intermediate resource is not the same as the subject to prevent some loops, -; ;; though main cycle prevention relies on data structure or more complex rule logic if needed. -; [(not= ?subject ?intermediate-resource)] -; ;; Ensure this-resource is not the same as intermediate for simple arrows like A -> B -; [(not= ?this-resource ?intermediate-resource)] -; [?this-resource :eacl/type ?this-resource-type]]]) ; this is super slow. different rules WIP.]]) - -(def slow-lookup-rules (build-slow-rules :eacl/type)) - -(def rules-lookup-subjects - '[;; Reachability rules to traverse relationships: - [(reachable ?resource ?subject) ; I think we need types here for speed. - [(tuple ?resource ?subject) ?resource+subject] - [?relationship :eacl.relationship/resource+subject ?resource+subject] - - [?relationship :eacl.relationship/resource ?resource] - [?relationship :eacl.relationship/subject ?subject]] - - [(reachable ?resource ?subject) - - [(tuple ?resource ?mid) ?resource+mid] - [?relationship :eacl.relationship/resource+subject ?resource+mid] ; range query? - - ; todo can we use tuple here? - [?relationship :eacl.relationship/resource ?resource] - [?relationship :eacl.relationship/subject ?mid] - (reachable ?mid ?subject)] - - ;; Direct permission check (copied and adapted from core2) - [(has-permission ?subject-type ?subject ?permission-name ?resource) - - [(tuple ?resource ?relation-name-in-tuple ?subject) ?resource+rel-name+subject] - [?relationship :eacl.relationship/resource+relation-name+subject ?resource+rel-name+subject] - - [?relationship :eacl.relationship/resource ?resource] ; subject has some relationship TO the resource - [?relationship :eacl.relationship/relation-name ?relation-name-in-tuple] - [?relationship :eacl.relationship/subject ?subject] ; subject of the relationship tuple - - ;; Permission definition: ?relation-name-in-perm-def grants ?permission-name on ?resource-type - [(tuple ?resource-type ?relation-name-in-perm-def ?permission-name) ?res-type+relation+permission] - [?perm-def :eacl.permission/resource-type+relation-name+permission-name ?res-type+relation+permission] - - [?perm-def :eacl.permission/resource-type ?resource-type] - [?perm-def :eacl.permission/permission-name ?permission-name] - [?perm-def :eacl.permission/relation-name ?relation-name-in-perm-def] ; THIS IS THE DIRECT GRANT - - ;; Match the relation name from the relationship tuple with the one in permission definition - [(= ?relation-name-in-tuple ?relation-name-in-perm-def)] - [(not= ?subject ?resource)] ; can we avoid this? - [?subject :eacl/type ?subject-type]] ; this is super slow. different rules WIP. - - ;; Indirect permission inheritance (copied from core2 - may need review/replacement with arrows) - ;; This rule means: ?subject gets ?permission-name on ?resource if: - ;; 1. A permission definition exists: for ?resource-type, ?relation-name-in-perm-def grants ?permission-name. - ;; 2. ?resource has a relationship (as a subject of the tuple) via ?relation-name-in-perm-def to some ?target. - ;; (e.g. doc D is "subject" of relation "group" to group G: D --group--> G) - ;; 3. ?subject can "reach" that ?target (e.g. user U is member of group G). - - [(has-permission ?subject-type ?subject ?permission-name ?resource) - ;; Permission definition - [(tuple ?resource-type ?relation-name-in-perm-def ?permission-name) ?res-type+relation+permission] - [?perm-def :eacl.permission/resource-type+relation-name+permission-name ?res-type+relation+permission] - - [?perm-def :eacl.permission/resource-type ?resource-type] - [?perm-def :eacl.permission/permission-name ?permission-name] - [?perm-def :eacl.permission/relation-name ?relation-name-in-perm-def] ; Direct relation specified in perm - - ;; Structural relationship: ?resource is linked to ?target via ?relation-name-in-perm-def - [(tuple ?target ?relation-name-in-perm-def ?resource) ?target+relation+resource] - [?structural-rel :eacl.relationship/resource+relation-name+subject ?target+relation+resource] - - [?structural-rel :eacl.relationship/subject ?resource] - [?structural-rel :eacl.relationship/relation-name ?relation-name-in-perm-def] - [?structural-rel :eacl.relationship/resource ?target] - - (reachable ?target ?subject) ; User must be able to reach the target of the structural relationship - [(not= ?subject ?resource)] - [?subject :eacl/type ?subject-type]] - - ;; Arrow permission rule: ?subject gets ?perm-name-on-this-resource if it has ?perm-name-on-related on an intermediate resource - ;; Example: User U gets :admin on VPC_X if VPC_X --:account--> ACC_Y and User U has :admin on ACC_Y. - ;; MODIFIED based on user feedback: Rule now expects intermediate --via-relation-name--> this-resource - ;; Example: User U gets :view on SERVER_X if ACC_Y --:account--> SERVER_X and User U has :admin on ACC_Y. - [(has-permission ?subject-type ?subject ?perm-name-on-this-resource ?this-resource) - - ; this order looks wrong. - ;; 1. Find an arrow permission definition for this-resource-type and perm-name-on-this-resource - [(tuple ?this-resource-type - ?via-relation-name - ?perm-on-related - ?perm-name-on-this-resource) ?res-type+relation+related-perm+permission] - [?arrow-perm-def - :eacl.arrow-permission/resource-type+source-relation-name+target-permission-name+permission-name - ?res-type+relation+related-perm+permission] - - ; can these move down for speed, or be decoupled in a 2nd phase? - [?arrow-perm-def :eacl.arrow-permission/resource-type ?this-resource-type] - [?arrow-perm-def :eacl.arrow-permission/permission-name ?perm-name-on-this-resource] - [?arrow-perm-def :eacl.arrow-permission/source-relation-name ?via-relation-name] ; e.g., :account (the relation name specified in Permission) - [?arrow-perm-def :eacl.arrow-permission/target-permission-name ?perm-on-related] ; e.g., :admin (on the intermediate/account) - - ;; 2. Find intermediate resource: ?intermediate-resource --via-relation-name--> ?this-resource - [(tuple ?this-resource ?via-relation-name ?intermediate-resource) ?resource+relation+mid-resource] - [?rel-linking-resources :eacl.relationship/resource+relation-name+subject ?resource+relation+mid-resource] - - [?rel-linking-resources :eacl.relationship/subject ?intermediate-resource] ; e.g., account is subject of tuple - [?rel-linking-resources :eacl.relationship/relation-name ?via-relation-name] ; relation is :account - [?rel-linking-resources :eacl.relationship/resource ?this-resource] ; e.g., server/vpc is resource of tuple - - ;; 3. Subject must have the target permission on the intermediate resource (recursive call) - (has-permission ?subject-type ?subject ?perm-on-related ?intermediate-resource) - [(not= ?subject ?this-resource)] ; Exclude self-references for safety - ;; Ensure the intermediate resource is not the same as the subject to prevent some loops, - ;; though main cycle prevention relies on data structure or more complex rule logic if needed. - [(not= ?subject ?intermediate-resource)] - ;; Ensure this-resource is not the same as intermediate for simple arrows like A -> B - [(not= ?this-resource ?intermediate-resource)] - ; TODO: this-resource looks dubious here. do we need it? - [?this-resource :eacl/type ?this-resource-type]]]) - -(def rules-lookup-resources - ; resource look has known subject Type + ID, and known resource type. - '[;; Reachability rules to traverse relationships: - [(reachable ?resource ?subject) ; I think we need types here for speed. - [(tuple ?resource ?subject) ?resource+subject] - [?relationship :eacl.relationship/resource+subject ?resource+subject] - - [?relationship :eacl.relationship/resource ?resource] - [?relationship :eacl.relationship/subject ?subject]] - - [(reachable ?resource ?subject) - - [(tuple ?resource ?mid) ?resource+mid] - [?relationship :eacl.relationship/resource+subject ?resource+mid] ; range query? - - ; todo can we use tuple here? - [?relationship :eacl.relationship/resource ?resource] - [?relationship :eacl.relationship/subject ?mid] - (reachable ?mid ?subject)] - - ;; Direct permission check (copied and adapted from core2) - [(has-permission ?subject ?permission-name ?resource-type ?resource) - - [(tuple ?resource ?relation-name-in-tuple ?subject) ?resource+rel-name+subject] - [?relationship :eacl.relationship/resource+relation-name+subject ?resource+rel-name+subject] - - [?relationship :eacl.relationship/resource ?resource] ; subject has some relationship TO the resource - [?relationship :eacl.relationship/relation-name ?relation-name-in-tuple] - [?relationship :eacl.relationship/subject ?subject] ; subject of the relationship tuple - - ;; Permission definition: ?relation-name-in-perm-def grants ?permission-name on ?resource-type - [(tuple ?resource-type ?relation-name-in-perm-def ?permission-name) ?res-type+relation+permission] - [?perm-def :eacl.permission/resource-type+relation-name+permission-name ?res-type+relation+permission] - - [?perm-def :eacl.permission/resource-type ?resource-type] - [?perm-def :eacl.permission/permission-name ?permission-name] - [?perm-def :eacl.permission/relation-name ?relation-name-in-perm-def] ; THIS IS THE DIRECT GRANT - - ;; Match the relation name from the relationship tuple with the one in permission definition - [(= ?relation-name-in-tuple ?relation-name-in-perm-def)] - [(not= ?subject ?resource)] ; can we avoid this? - [?resource :eacl/type ?resource-type]] - - ;; Indirect permission inheritance (copied from core2 - may need review/replacement with arrows) - ;; This rule means: ?subject gets ?permission-name on ?resource if: - ;; 1. A permission definition exists: for ?resource-type, ?relation-name-in-perm-def grants ?permission-name. - ;; 2. ?resource has a relationship (as a subject of the tuple) via ?relation-name-in-perm-def to some ?target. - ;; (e.g. doc D is "subject" of relation "group" to group G: D --group--> G) - ;; 3. ?subject can "reach" that ?target (e.g. user U is member of group G). - - [(has-permission ?subject ?permission-name ?resource-type ?resource) - ;; Permission definition - ;; order looks dubious - [(tuple ?resource-type ?relation-name-in-perm-def ?permission-name) ?res-type+relation+permission] - [?perm-def :eacl.permission/resource-type+relation-name+permission-name ?res-type+relation+permission] - - [?perm-def :eacl.permission/resource-type ?resource-type] - [?perm-def :eacl.permission/permission-name ?permission-name] - [?perm-def :eacl.permission/relation-name ?relation-name-in-perm-def] ; Direct relation specified in perm - - ;; Structural relationship: ?resource is linked to ?target via ?relation-name-in-perm-def - [(tuple ?target ?relation-name-in-perm-def ?resource) ?target+relation+resource] - [?structural-rel :eacl.relationship/resource+relation-name+subject ?target+relation+resource] - - [?structural-rel :eacl.relationship/subject ?resource] - [?structural-rel :eacl.relationship/relation-name ?relation-name-in-perm-def] - [?structural-rel :eacl.relationship/resource ?target] - - (reachable ?target ?subject) ; User must be able to reach the target of the structural relationship - [(not= ?subject ?resource)] - [?resource :eacl/type ?this-resource-type]] ; is this correct? - - ;; Arrow permission rule: ?subject gets ?perm-name-on-this-resource if it has ?perm-name-on-related on an intermediate resource - ;; Example: User U gets :admin on VPC_X if VPC_X --:account--> ACC_Y and User U has :admin on ACC_Y. - ;; MODIFIED based on user feedback: Rule now expects intermediate --via-relation-name--> this-resource - ;; Example: User U gets :view on SERVER_X if ACC_Y --:account--> SERVER_X and User U has :admin on ACC_Y. - [(has-permission ?subject ?perm-name-on-this-resource ?this-resource-type ?this-resource) - - ;; 1. Find an arrow permission definition for this-resource-type and perm-name-on-this-resource - [(tuple ?this-resource-type - ?via-relation-name - ?perm-on-related - ?perm-name-on-this-resource) ?res-type+relation+related-perm+permission] - [?arrow-perm-def - :eacl.arrow-permission/resource-type+source-relation-name+target-permission-name+permission-name - ?res-type+relation+related-perm+permission] - - ; can these move down for speed, or be decoupled in a 2nd phase? - [?arrow-perm-def :eacl.arrow-permission/resource-type ?this-resource-type] - [?arrow-perm-def :eacl.arrow-permission/permission-name ?perm-name-on-this-resource] - [?arrow-perm-def :eacl.arrow-permission/source-relation-name ?via-relation-name] ; e.g., :account (the relation name specified in Permission) - [?arrow-perm-def :eacl.arrow-permission/target-permission-name ?perm-on-related] ; e.g., :admin (on the intermediate/account) - - ;; 2. Find intermediate resource: ?intermediate-resource --via-relation-name--> ?this-resource - [(tuple ?this-resource ?via-relation-name ?intermediate-resource) ?resource+relation+mid-resource] - [?rel-linking-resources :eacl.relationship/resource+relation-name+subject ?resource+relation+mid-resource] - - [?rel-linking-resources :eacl.relationship/subject ?intermediate-resource] ; e.g., account is subject of tuple - [?rel-linking-resources :eacl.relationship/relation-name ?via-relation-name] ; relation is :account - [?rel-linking-resources :eacl.relationship/resource ?this-resource] ; e.g., server/vpc is resource of tuple - - [?intermediate-resource :eacl/type ?intermediate-resource-type] ; do we need this? - - ;; 3. Subject must have the target permission on the intermediate resource (recursive call) - (has-permission ?subject ?perm-on-related ?intermediate-resource-type ?intermediate-resource) - [(not= ?subject ?this-resource)] ; Exclude self-references for safety - ;; Ensure the intermediate resource is not the same as the subject to prevent some loops, - ;; though main cycle prevention relies on data structure or more complex rule logic if needed. - [(not= ?subject ?intermediate-resource)] - ;; Ensure this-resource is not the same as intermediate for simple arrows like A -> B - [(not= ?this-resource ?intermediate-resource)] - [?this-resource :eacl/type ?this-resource-type]]]) - -;(def rules-lookup-subjects -; ; lookup-subjects knows resource & subject type which implies knowing resource type. -; '[;; Reachability rules to traverse relationships: -; [(reachable ?resource ?subject) -; ; todo use reachable tuple -; [(tuple ?resource ?subject) ?resource+subject] -; [?relationship :eacl.relationship/resource+subject ?resource+subject] -; -; [?relationship :eacl.relationship/resource ?resource] -; [?relationship :eacl.relationship/subject ?subject]] -; -; [(reachable ?resource ?subject) -; ; don't think this will work... -; [(tuple ?resource ?mid) ?resource+mid] -; [?relationship :eacl.relationship/resource+subject ?resource+mid] -; -; [?relationship :eacl.relationship/resource ?resource] -; [?relationship :eacl.relationship/subject ?mid] -; (reachable ?mid ?subject)] -; -; ;; Direct permission check -; [(has-permission ?resource ?permission-name ?subject-type ?subject) -; -; [(tuple ?resource ?relation-name-in-tuple ?subject) ?resource+rel-name+subject] -; [?relationship :eacl.relationship/resource+relation-name+subject ?resource+rel-name+subject] -; -; [?relationship :eacl.relationship/resource ?resource] ; subject has some relationship TO the resource -; [?relationship :eacl.relationship/relation-name ?relation-name-in-tuple] -; [?relationship :eacl.relationship/subject ?subject] ; subject of the relationship tuple -; -; ;; Permission definition: ?relation-name-in-perm-def grants ?permission-name on ?resource-type -; [(tuple ?resource-type ?relation-name-in-tuple ?permission-name) ?res-type+relation+permission] -; [?perm-def :eacl.permission/resource-type+relation-name+permission-name ?res-type+relation+permission] -; -; [?perm-def :eacl.permission/resource-type ?resource-type] -; [?perm-def :eacl.permission/permission-name ?permission-name] -; [?perm-def :eacl.permission/relation-name ?relation-name-in-tuple] ; THIS IS THE DIRECT GRANT -; -; ;; Match the relation name from the relationship tuple with the one in permission definition -; ;[(= ?relation-name-in-tuple ?relation-name-in-perm-def)] ; can this be unified better? should this be higher up? -; -; [(not= ?subject ?resource)]] -; -; ;; Indirect permission inheritance (copied from core2 - may need review/replacement with arrows) -; ;; This rule means: ?subject gets ?permission-name on ?resource if: -; ;; 1. A permission definition exists: for ?resource-type, ?relation-name-in-perm-def grants ?permission-name. -; ;; 2. ?resource has a relationship (as a subject of the tuple) via ?relation-name-in-perm-def to some ?target. -; ;; (e.g. doc D is "subject" of relation "group" to group G: D --group--> G) -; ;; 3. ?subject can "reach" that ?target (e.g. user U is member of group G). -; -; [(has-permission ?resource ?permission-name ?subject-type ?subject) -; ;; Permission definition -; ;; I don't think tuple makes sense here... -; ;[(tuple ?resource-type ?relation-name-in-perm-def ?permission-name) ?res-type+relation+permission] -; ;[?perm-def :eacl.permission/resource-type+relation-name+permission-name ?res-type+relation+permission] -; -; [?perm-def :eacl.permission/resource-type ?resource-type] -; [?perm-def :eacl.permission/permission-name ?permission-name] -; [?perm-def :eacl.permission/relation-name ?relation-name-in-perm-def] ; Direct relation specified in perm -; -; ;; Structural relationship: ?resource is linked to ?target via ?relation-name-in-perm-def -; [(tuple ?target ?relation-name-in-perm-def ?resource) ?target+relation+resource] -; [?structural-rel :eacl.relationship/resource+relation-name+subject ?target+relation+resource] -; -; [?structural-rel :eacl.relationship/subject ?resource] -; [?structural-rel :eacl.relationship/relation-name ?relation-name-in-perm-def] -; [?structural-rel :eacl.relationship/resource ?target] -; -; (reachable ?target ?subject) ; User must be able to reach the target of the structural relationship -; [?resource :eacl/type ?resource-type] ; super slow. different rules WIP. -; [?subject :eacl/type ?subject-type] -; [(not= ?subject ?resource)]] -; -; ;; Arrow permission rule: ?subject gets ?perm-name-on-this-resource if it has ?perm-name-on-related on an intermediate resource -; ;; Example: User U gets :admin on VPC_X if VPC_X --:account--> ACC_Y and User U has :admin on ACC_Y. -; ;; MODIFIED based on user feedback: Rule now expects intermediate --via-relation-name--> this-resource -; ;; Example: User U gets :view on SERVER_X if ACC_Y --:account--> SERVER_X and User U has :admin on ACC_Y. -; [(has-permission ?this-resource ?perm-name-on-this-resource ?subject-type ?subject) -; -; ;; 1. Find an arrow permission definition for this-resource-type and perm-name-on-this-resource -; [(tuple ?this-resource-type -; ?via-relation-name -; ?perm-on-related -; ?perm-name-on-this-resource) ?res-type+relation+related-perm+permission] -; [?arrow-perm-def -; :eacl.arrow-permission/resource-type+source-relation-name+target-permission-name+permission-name -; ?res-type+relation+related-perm+permission] -; -; ; can these move down for speed, or be decoupled in a 2nd phase? -; [?arrow-perm-def :eacl.arrow-permission/resource-type ?this-resource-type] -; [?arrow-perm-def :eacl.arrow-permission/permission-name ?perm-name-on-this-resource] -; [?arrow-perm-def :eacl.arrow-permission/source-relation-name ?via-relation-name] ; e.g., :account (the relation name specified in Permission) -; [?arrow-perm-def :eacl.arrow-permission/target-permission-name ?perm-on-related] ; e.g., :admin (on the intermediate/account) -; -; ;; 2. Find intermediate resource: ?intermediate-resource --via-relation-name--> ?this-resource -; [(tuple ?this-resource ?via-relation-name ?intermediate-resource) ?resource+relation+mid-resource] -; [?rel-linking-resources :eacl.relationship/resource+relation-name+subject ?resource+relation+mid-resource] -; -; [?rel-linking-resources :eacl.relationship/subject ?intermediate-resource] ; e.g., account is subject of tuple -; [?rel-linking-resources :eacl.relationship/relation-name ?via-relation-name] ; relation is :account -; [?rel-linking-resources :eacl.relationship/resource ?this-resource] ; e.g., server/vpc is resource of tuple -; -; ;[?this-resource :eacl/type ?this-resource-type] -; ;[?subject :eacl/type ?subject-type] -; [?intermediate-resource :resource/type ?intermediate-resource-type] -; -; ;; 3. Subject must have the target permission on the intermediate resource (recursive call) -; (has-permission ?subject ?perm-on-related ?intermediate-resource-type ?intermediate-resource) -; [(not= ?subject ?this-resource)] ; Exclude self-references for safety -; ;; Ensure the intermediate resource is not the same as the subject to prevent some loops, -; ;; though main cycle prevention relies on data structure or more complex rule logic if needed. -; [(not= ?subject ?intermediate-resource)] -; ;; Ensure this-resource is not the same as intermediate for simple arrows like A -> B -; [(not= ?this-resource ?intermediate-resource)]]]) -; this is super slow. different rules WIP.]]) diff --git a/modules/eacl-datomic/src/eacl/datomic/rules/optimized.clj b/modules/eacl-datomic/src/eacl/datomic/rules/optimized.clj deleted file mode 100644 index 3cd59d688..000000000 --- a/modules/eacl-datomic/src/eacl/datomic/rules/optimized.clj +++ /dev/null @@ -1,427 +0,0 @@ -(ns eacl.datomic.rules.optimized - "Optimized Datalog rules for EACL performance improvements") - -(def check-permission-rules - "Recursive Datalog rules for can? & lookup-resources using unified permission schema." - '[;; Optimized reachability using tuples - [(reachable ?resource ?subject) - ;; Direct relationship - most common case - [(tuple ?resource ?subject) ?resource+subject] - [?relationship :eacl.relationship/resource+subject ?resource+subject]] - - [(reachable ?resource ?subject) - ;; Indirect relationship - use tuple for first hop - [(tuple ?resource ?mid) ?resource+mid] - [?relationship :eacl.relationship/resource+subject ?resource+mid] - ;; Only traverse if needed - (reachable ?mid ?subject)] - - ;; Direct permission - unified schema (no source-relation-name) - [(has-permission ?subject-type ?subject ?permission-name ?resource-type ?resource) - - ;; Find relationships for this resource - [?relationship :eacl.relationship/resource ?resource] - [?relationship :eacl.relationship/resource-type ?resource-type] - [?relationship :eacl.relationship/subject ?subject] - [?relationship :eacl.relationship/subject-type ?subject-type] - [?relationship :eacl.relationship/relation-name ?relation-name] - - ;; Find direct permission (no source-relation-name means direct) - [?perm-def :eacl.permission/resource-type ?resource-type] - [?perm-def :eacl.permission/permission-name ?permission-name] - [?perm-def :eacl.permission/target-type :relation] - [?perm-def :eacl.permission/target-name ?relation-name] - [?perm-def :eacl.permission/source-relation-name :self] - - ;; Exclude self-references - [(not= ?subject ?resource)]] - - ;; Indirect permission inheritance via direct permissions - [(has-permission ?subject-type ?subject ?permission-name ?resource-type ?resource) - - ;; Find direct permission definitions for this resource type - [?perm-def :eacl.permission/resource-type ?resource-type] - [?perm-def :eacl.permission/permission-name ?permission-name] - [?perm-def :eacl.permission/target-type :relation] - [?perm-def :eacl.permission/target-name ?relation-name] - [?perm-def :eacl.permission/source-relation-name :self] - - ;; Find structural relationships where resource is the subject - [?structural-rel :eacl.relationship/subject ?resource] - [?structural-rel :eacl.relationship/subject-type ?resource-type] - [?structural-rel :eacl.relationship/relation-name ?relation-name] - [?structural-rel :eacl.relationship/resource ?target] - [?structural-rel :eacl.relationship/resource-type ?target-type] - - ;; Check reachability last - (reachable ?target ?subject) - [(not= ?subject ?resource)]] - - ;; Arrow permission to permission - unified schema - [(has-permission ?subject-type ?subject ?perm-name-on-this-resource ?this-resource-type ?this-resource) - - ;; Find arrow permission definitions that target permissions - [?arrow-perm :eacl.permission/resource-type ?this-resource-type] - [?arrow-perm :eacl.permission/permission-name ?perm-name-on-this-resource] - [?arrow-perm :eacl.permission/source-relation-name ?via-relation] - [?arrow-perm :eacl.permission/target-type :permission] - [?arrow-perm :eacl.permission/target-name ?perm-on-related] - - ;; Find intermediate resource - [?rel-linking :eacl.relationship/resource-type ?this-resource-type] - [?rel-linking :eacl.relationship/resource ?this-resource] - [?rel-linking :eacl.relationship/relation-name ?via-relation] - [?rel-linking :eacl.relationship/subject ?intermediate-resource] - [?rel-linking :eacl.relationship/subject-type ?intermediate-resource-type] - - ;; Recursive permission check - (has-permission ?subject-type ?subject ?perm-on-related ?intermediate-resource-type ?intermediate-resource) - - ;; Safety checks - [(not= ?subject ?this-resource)] - [(not= ?subject ?intermediate-resource)] - [(not= ?this-resource ?intermediate-resource)]] - - ;; Arrow permission to relation - unified schema - [(has-permission ?subject-type ?subject ?perm-name-on-this-resource ?this-resource-type ?this-resource) - - ;; Find arrow permission definitions that target relations - [?arrow-perm :eacl.permission/resource-type ?this-resource-type] - [?arrow-perm :eacl.permission/permission-name ?perm-name-on-this-resource] - [?arrow-perm :eacl.permission/source-relation-name ?via-relation] - [?arrow-perm :eacl.permission/target-type :relation] - [?arrow-perm :eacl.permission/target-name ?target-relation] - - ;; Find intermediate resource - [?rel-linking :eacl.relationship/resource-type ?this-resource-type] - [?rel-linking :eacl.relationship/resource ?this-resource] - [?rel-linking :eacl.relationship/relation-name ?via-relation] - [?rel-linking :eacl.relationship/subject ?intermediate-resource] - [?rel-linking :eacl.relationship/subject-type ?intermediate-resource-type] - - ;; Check if subject has the target relation on intermediate resource - [?target-rel :eacl.relationship/resource ?intermediate-resource] - [?target-rel :eacl.relationship/resource-type ?intermediate-resource-type] - [?target-rel :eacl.relationship/subject ?subject] - [?target-rel :eacl.relationship/subject-type ?subject-type] - [?target-rel :eacl.relationship/relation-name ?target-relation] - - ;; Safety checks - [(not= ?subject ?this-resource)] - [(not= ?subject ?intermediate-resource)] - [(not= ?this-resource ?intermediate-resource)]]]) - -;(def check-permission-rules-broken -; '[(reachable ?resource ?subject) -; [?structural-rel :eacl.relationship/subject ?subject] -; [?structural-rel :eacl.relationship/resource ?resource] -; -; (reachable ?resource ?subject) -; [?structural-rel :eacl.relationship/subject ?mid] -; [?structural-rel :eacl.relationship/resource ?resource] -; (reachable ?mid ?subject) -; -; (has-permission ?subject-type ?subject ?permission-name ?resource-type ?resource) -; [?relationship :eacl.relationship/resource ?resource] -; [?relationship :eacl.relationship/subject ?subject] -; [?relationship :eacl.relationship/relation-name ?relation-name] -; [?relationship :eacl.relationship/resource-type ?resource-type] -; [?relationship :eacl.relationship/subject-type ?subject-type] -; [(tuple ?resource-type ?relation-name ?permission-name) ?perm-tuple] -; [?perm-def :eacl.permission/resource-type+relation-name+permission-name ?perm-tuple] -; [(not= ?subject ?resource)] -; -; (has-permission ?subject-type ?subject ?permission-name ?resource-type ?resource) -; [?perm-def :eacl.permission/resource-type ?resource-type] -; [?perm-def :eacl.permission/permission-name ?permission-name] -; [?perm-def :eacl.permission/relation-name ?relation-name] -; [?structural-rel :eacl.relationship/subject ?resource] -; [?structural-rel :eacl.relationship/relation-name ?relation-name] -; [?structural-rel :eacl.relationship/resource ?target] -; [?structural-rel :eacl.relationship/subject-type ?resource-type] -; [?structural-rel :eacl.relationship/resource-type ?target-type] -; (reachable ?target ?subject) -; [(not= ?subject ?resource)] -; -; (has-permission ?subject-type ?subject ?perm-name-on-this-resource ?this-resource-type ?this-resource) -; [?arrow-perm :eacl.arrow-permission/resource-type ?this-resource-type] -; [?arrow-perm :eacl.arrow-permission/permission-name ?perm-name-on-this-resource] -; [?arrow-perm :eacl.arrow-permission/source-relation-name ?via-relation] -; [?arrow-perm :eacl.arrow-permission/target-permission-name ?perm-on-related] -; [?rel-linking :eacl.relationship/resource ?this-resource] -; [?rel-linking :eacl.relationship/resource-type ?this-resource-type] -; [?rel-linking :eacl.relationship/relation-name ?via-relation] -; [?rel-linking :eacl.relationship/subject ?intermediate-resource] -; [?rel-linking :eacl.relationship/subject-type ?intermediate-resource-type] -; (has-permission ?subject-type ?subject ?perm-on-related ?intermediate-resource-type ?intermediate-resource) -; [(not= ?subject ?this-resource)] -; [(not= ?subject ?intermediate-resource)] -; [(not= ?this-resource ?intermediate-resource)]]) - -(def rules-lookup-subjects - "Optimized rules for lookup-subjects using unified permission schema" - '[;; Reachability rules remain the same - ; Note: resource is known. subject is unknown. - [(reachable ?resource ?subject) - [(tuple ?resource ?subject) ?resource+subject] - [?relationship :eacl.relationship/resource+subject ?resource+subject]] - - [(reachable ?resource ?subject) - [(tuple ?resource ?mid) ?resource+mid] - [?relationship :eacl.relationship/resource+subject ?resource+mid] - (reachable ?mid ?subject)] - - ;; Direct permission check - unified schema - [(has-permission ?subject-type ?subject ?permission-name ?resource-type ?resource) - - ;; Find relationships for this resource - [?relationship :eacl.relationship/resource ?resource] - [?relationship :eacl.relationship/subject ?subject] - [?relationship :eacl.relationship/relation-name ?relation-name] - [?relationship :eacl.relationship/resource-type ?resource-type] - [?relationship :eacl.relationship/subject-type ?subject-type] - - ;; Find direct permission (no source-relation-name means direct) - [?perm-def :eacl.permission/resource-type ?resource-type] - [?perm-def :eacl.permission/permission-name ?permission-name] - [?perm-def :eacl.permission/target-type :relation] - [?perm-def :eacl.permission/target-name ?relation-name] - [?perm-def :eacl.permission/source-relation-name :self] - - [(not= ?subject ?resource)]] - - ;; Indirect permission inheritance via direct permissions - [(has-permission ?subject-type ?subject ?permission-name ?resource-type ?resource) - ;; Find direct permission definitions - [?perm-def :eacl.permission/resource-type ?resource-type] - [?perm-def :eacl.permission/permission-name ?permission-name] - [?perm-def :eacl.permission/target-type :relation] - [?perm-def :eacl.permission/target-name ?relation-name] - [?perm-def :eacl.permission/source-relation-name :self] - - ;; Find structural relationships - [?structural-rel :eacl.relationship/subject ?resource] - [?structural-rel :eacl.relationship/relation-name ?relation-name] - [?structural-rel :eacl.relationship/resource ?target] - [?structural-rel :eacl.relationship/subject-type ?resource-type] - [?structural-rel :eacl.relationship/resource-type ?target-type] - - (reachable ?target ?subject) - [(not= ?subject ?resource)]] - - ;; Arrow permission to permission - unified schema - [(has-permission ?subject-type ?subject ?perm-name-on-this-resource ?this-resource-type ?this-resource) - - ;; Find arrow permissions that target permissions - [?arrow-perm :eacl.permission/resource-type ?this-resource-type] - [?arrow-perm :eacl.permission/permission-name ?perm-name-on-this-resource] - [?arrow-perm :eacl.permission/source-relation-name ?via-relation] - [?arrow-perm :eacl.permission/target-type :permission] - [?arrow-perm :eacl.permission/target-name ?perm-on-related] - - ;; Find intermediate - [?rel-linking :eacl.relationship/resource ?this-resource] - [?rel-linking :eacl.relationship/relation-name ?via-relation] - [?rel-linking :eacl.relationship/subject ?intermediate-resource] - [?rel-linking :eacl.relationship/subject-type ?intermediate-resource-type] - [?rel-linking :eacl.relationship/resource-type ?this-resource-type] - - (has-permission ?subject-type ?subject ?perm-on-related ?intermediate-resource-type ?intermediate-resource) - - [(not= ?subject ?this-resource)] - [(not= ?subject ?intermediate-resource)] - [(not= ?this-resource ?intermediate-resource)]] - - ;; Arrow permission to relation - unified schema - [(has-permission ?subject-type ?subject ?perm-name-on-this-resource ?this-resource-type ?this-resource) - - ;; Find arrow permissions that target relations - [?arrow-perm :eacl.permission/resource-type ?this-resource-type] - [?arrow-perm :eacl.permission/permission-name ?perm-name-on-this-resource] - [?arrow-perm :eacl.permission/source-relation-name ?via-relation] - [?arrow-perm :eacl.permission/target-type :relation] - [?arrow-perm :eacl.permission/target-name ?target-relation] - - ;; Find intermediate - [?rel-linking :eacl.relationship/resource ?this-resource] - [?rel-linking :eacl.relationship/relation-name ?via-relation] - [?rel-linking :eacl.relationship/subject ?intermediate-resource] - [?rel-linking :eacl.relationship/subject-type ?intermediate-resource-type] - [?rel-linking :eacl.relationship/resource-type ?this-resource-type] - - ;; Check if subject has the target relation on intermediate resource - [?target-rel :eacl.relationship/resource ?intermediate-resource] - [?target-rel :eacl.relationship/resource-type ?intermediate-resource-type] - [?target-rel :eacl.relationship/subject ?subject] - [?target-rel :eacl.relationship/subject-type ?subject-type] - [?target-rel :eacl.relationship/relation-name ?target-relation] - - [(not= ?subject ?this-resource)] - [(not= ?subject ?intermediate-resource)] - [(not= ?this-resource ?intermediate-resource)]]]) - -;(def rules-lookup-resources -; "Optimized rules for lookup-resources - subject-centric approach" -; '[;; Helper rule: find relationships from subject -; -; [(relations-between-subject-resource ?subject ?relation ?resource-type ?resource) -; [(tuple ?subject ?resource-type) ?subject+resource-type] -; [?relationship :eacl.relationship/subject+resource-type ?subject+resource-type] -; -; [?relationship :eacl.relationship/relation-name ?relation] -; [?relationship :eacl.relationship/subject ?subject] -; [?relationship :eacl.relationship/resource ?resource] -; [?relationship :eacl.relationship/resource-type ?resource-type]] -; -; [(subject-has-relationships ?subject-type ?subject ?relation ?resource-type ?resource) -; ;; Start from subject -; -; [(tuple ?subject ?relation ?resource) ?subject+relation+resource] -; [?relationship :eacl.relationship/subject+relation-name+resource ?subject+relation+resource] -; -; [?relationship :eacl.relationship/subject ?subject] -; [?relationship :eacl.relationship/resource ?resource] -; [?relationship :eacl.relationship/relation-name ?relation] -; [?relationship :eacl.relationship/subject-type ?subject-type] -; [?relationship :eacl.relationship/resource-type ?resource-type]] -; -; ;; Direct permission check - subject-centric -; [(has-permission ?subject-type ?subject ?permission ?resource-type ?resource) -; ;; Check if resource is of correct type -; ;[?resource :eacl/type ?resource-type] -; -; [(tuple ?resource-type ?permission) ?rtype+permission] -; [?perm :eacl.permission/resource-type+permission-name ?rtype+permission] -; -; ;; Check if relation grants permission -; ;[?perm :eacl.permission/resource-type ?resource-type] -; [?perm :eacl.permission/relation-name ?relation] -; ;[?perm :eacl.permission/permission-name ?permission] -; -; (subject-has-relationships ?subject-type ?subject ?relation ?resource-type ?resource)] -; -; ;; Indirect permission via intermediate resources -; [(has-permission ?subject-type ?subject ?permission ?resource-type ?resource) -; ;; Find relationships where subject can reach an intermediate -; -; ; Find relations that grant this permission: -; [(tuple ?resource-type ?permission) ?rtype+permission] -; [?perm-def :eacl.permission/resource-type+permission-name ?rtype+permission] -; [?perm-def :eacl.permission/resource-type ?resource-type] -; [?perm-def :eacl.permission/permission-name ?permission] -; [?perm-def :eacl.permission/relation-name ?rel2] -; -; (relations-between-subject-resource ?subject ?rel1 ?intermediate-type ?intermediate) -; ;(subject-has-relationships ?subject-type ?subject ?rel1 ?intermediate-type ?intermediate) -; -; ;[(tuple ?intermediate ?rel2 ?resource-type) ?intermediate+rel2+rtype] -; ;[?relationship2 :eacl.relationship/subject+relation-name+resource-type ?intermediate+rel2+rtype] -; -; ;; Find resources connected to intermediate via rel2 -; [?relationship2 :eacl.relationship/subject-type ?intermediate-type] -; [?relationship2 :eacl.relationship/subject ?intermediate] -; [?relationship2 :eacl.relationship/relation-name ?rel2] -; [?relationship2 :eacl.relationship/resource ?resource] -; [?relationship2 :eacl.relationship/resource-type ?resource-type]] -; -; ;; Verify resource type -; ;[?resource :eacl/type ?resource-type]] -; -; ;; Arrow permission - optimized for subject-centric lookup -; [(has-permission ?subject-type ?subject ?permission ?resource-type ?resource) -; ; known: subject-type ,subject, permission, resource-type. -; ;; Find arrow permissions for the target resource type and permission -; -; [(tuple ?resource-type ?permission) ?rtype+perm] -; [?arrow :eacl.arrow-permission/resource-type+permission-name ?rtype+perm] -; -; ;[?arrow :eacl.arrow-permission/resource-type ?resource-type] -; ;[?arrow :eacl.arrow-permission/permission-name ?permission] -; [?arrow :eacl.arrow-permission/source-relation-name ?via-rel] -; [?arrow :eacl.arrow-permission/target-permission-name ?target-perm] -; -; ;; Find intermediate resources linked to target resource (resource is not known here) -; ; the problem is we know via-rel, but not ?intermediate or ?resource. -; ; how to cull ?resource here. -; ; we should be able to narrow down relationships here to find the relevant ?intermediate subjects for traversal -; -; ;[(tuple ?resource-type ?via-rel) ?rtype+via-rel] -; ;[?link :eacl.relationship/resource-type+relation-name ?rtype+via-rel] -; ;[?link :eacl.relationship/resource-type+relation-name ?subject+via-rel+rtype] -; -; [?link :eacl.relationship/resource ?resource] ; this is unknown and expands. -; [?link :eacl.relationship/resource-type ?resource-type] ; this is known via arg. -; [?link :eacl.relationship/relation-name ?via-rel] ; this is known via arrow. -; -; [?link :eacl.relationship/subject ?intermediate] ; this is looked up here -; [?link :eacl.relationship/subject-type ?intermediate-type] ; this is looked up here -; -; ;; Get intermediate resource type -; ;[?intermediate :eacl/type ?intermediate-type] -; -; ;; Check if subject has target permission on intermediate (recursive) -; (has-permission ?subject-type ?subject ?target-perm ?intermediate-type ?intermediate)]]) - -(def rules-lookup-resources - ; not currently used. lookup-resources currently uses the check-permission rules, which are slow. - "Too slow. Superseded by direct index impl. - Was optimized rules for lookup-resources - subject-centric approach" - '[;; Helper rule: find relationships from subject - [(subject-has-relationships ?subject ?relation ?resource) - ;; Start from subject - [?relationship :eacl.relationship/subject ?subject] - [?relationship :eacl.relationship/relation-name ?relation] - [?relationship :eacl.relationship/resource ?resource]] - - ;; Direct permission check - subject-centric - [(has-permission ?subject-type ?subject ?permission ?resource-type ?resource) - ;; Start from subject's relationships - (subject-has-relationships ?subject ?relation ?resource) - - ;; Check if resource is of correct type - [?resource :eacl/type ?resource-type] - - ;; Check if relation grants permission - [?perm :eacl.permission/resource-type ?resource-type] - [?perm :eacl.permission/relation-name ?relation] - [?perm :eacl.permission/permission-name ?permission]] - - ;; Indirect permission via intermediate resources - [(has-permission ?subject ?permission ?resource-type ?resource) - ;; Find relationships where subject can reach an intermediate - (subject-has-relationships ?subject ?rel1 ?intermediate) - - ;; Find permission definition that grants access via relation - [?perm-def :eacl.permission/resource-type ?resource-type] - [?perm-def :eacl.permission/permission-name ?permission] - [?perm-def :eacl.permission/relation-name ?rel2] - - ;; Find resources connected to intermediate via rel2 - [?relationship2 :eacl.relationship/subject ?intermediate] - [?relationship2 :eacl.relationship/relation-name ?rel2] - [?relationship2 :eacl.relationship/resource ?resource] - - ;; Verify resource type - [?resource :eacl/type ?resource-type]] - - ;; Arrow permission - optimized for subject-centric lookup - [(has-permission ?subject ?permission ?resource-type ?resource) - ;; Find arrow permissions for the target resource type and permission - [?arrow :eacl.arrow-permission/resource-type ?resource-type] - [?arrow :eacl.arrow-permission/permission-name ?permission] - [?arrow :eacl.arrow-permission/source-relation-name ?via-rel] - [?arrow :eacl.arrow-permission/target-permission-name ?target-perm] - - ;; Find resources of target type - [?resource :eacl/type ?resource-type] - - ;; Find intermediate resources linked to target resource - [?link :eacl.relationship/resource ?resource] - [?link :eacl.relationship/relation-name ?via-rel] - [?link :eacl.relationship/subject ?intermediate] - - ;; Get intermediate resource type - [?intermediate :eacl/type ?intermediate-type] - - ;; Check if subject has target permission on intermediate (recursive) - (has-permission ?subject ?target-perm ?intermediate-type ?intermediate)]]) \ No newline at end of file diff --git a/modules/eacl-datomic/src/eacl/datomic/rules/optimized_old.clj b/modules/eacl-datomic/src/eacl/datomic/rules/optimized_old.clj deleted file mode 100644 index 26ffe2d05..000000000 --- a/modules/eacl-datomic/src/eacl/datomic/rules/optimized_old.clj +++ /dev/null @@ -1,225 +0,0 @@ -(ns eacl.datomic.rules.optimized-old - "Optimized Datalog rules for EACL performance improvements") - -(def check-permission-rules - "Optimized rules for can? - reordered clauses and better tuple usage" - '[;; Optimized reachability using tuples - [(reachable ?resource ?subject) - ;; Direct relationship - most common case - [(tuple ?resource ?subject) ?resource+subject] - [?relationship :eacl.relationship/resource+subject ?resource+subject]] - - [(reachable ?resource ?subject) - ;; Indirect relationship - use tuple for first hop - [(tuple ?resource ?mid) ?resource+mid] - [?relationship :eacl.relationship/resource+subject ?resource+mid] - ;; Only traverse if needed - (reachable ?mid ?subject)] - - ;; Direct permission - optimized clause ordering - [(has-permission ?subject ?permission-name ?resource) - ;; Get resource type first - [?resource :resource/type ?resource-type] - - ;; Find relationships for this resource - [?relationship :eacl.relationship/resource ?resource] - [?relationship :eacl.relationship/subject ?subject] - [?relationship :eacl.relationship/relation-name ?relation-name] - - ;; Check permission using tuple - [(tuple ?resource-type ?relation-name ?permission-name) ?perm-tuple] - [?perm-def :eacl.permission/resource-type+relation-name+permission-name ?perm-tuple] - - ;; Exclude self-references - [(not= ?subject ?resource)]] - - ;; Indirect permission inheritance - optimized - [(has-permission ?subject ?permission-name ?resource) - ;; Get resource type first (we already have the resource) - [?resource :resource/type ?resource-type] - - ;; Find permission definitions for this resource type - [?perm-def :eacl.permission/resource-type ?resource-type] - [?perm-def :eacl.permission/permission-name ?permission-name] - [?perm-def :eacl.permission/relation-name ?relation-name] - - ;; Find structural relationships where resource is the subject - [?structural-rel :eacl.relationship/subject ?resource] - [?structural-rel :eacl.relationship/relation-name ?relation-name] - [?structural-rel :eacl.relationship/resource ?target] - - ;; Check reachability last - (reachable ?target ?subject) - [(not= ?subject ?resource)]] - - ;; Arrow permission - optimized - [(has-permission ?subject ?perm-name-on-this-resource ?this-resource) - ;; Get resource type from the resource we already have - [?this-resource :resource/type ?this-resource-type] - - ;; Find arrow permission definitions - [?arrow-perm :eacl.arrow-permission/resource-type ?this-resource-type] - [?arrow-perm :eacl.arrow-permission/permission-name ?perm-name-on-this-resource] - [?arrow-perm :eacl.arrow-permission/source-relation-name ?via-relation] - [?arrow-perm :eacl.arrow-permission/target-permission-name ?perm-on-related] - - ;; Find intermediate resource - [?rel-linking :eacl.relationship/resource ?this-resource] - [?rel-linking :eacl.relationship/relation-name ?via-relation] - [?rel-linking :eacl.relationship/subject ?intermediate-resource] - - ;; Recursive permission check - (has-permission ?subject ?perm-on-related ?intermediate-resource) - - ;; Safety checks - [(not= ?subject ?this-resource)] - [(not= ?subject ?intermediate-resource)] - [(not= ?this-resource ?intermediate-resource)]]]) - -(def rules-lookup-subjects - "Optimized rules for lookup-subjects" - '[;; Reachability rules remain the same - [(reachable ?resource ?subject) - [(tuple ?resource ?subject) ?resource+subject] - [?relationship :eacl.relationship/resource+subject ?resource+subject]] - - [(reachable ?resource ?subject) - [(tuple ?resource ?mid) ?resource+mid] - [?relationship :eacl.relationship/resource+subject ?resource+mid] - (reachable ?mid ?subject)] - - ;; Direct permission check - optimized for known resource - [(has-permission ?subject-type ?subject ?permission-name ?resource) - ;; Get resource type (we already have resource entity) - [?resource :resource/type ?resource-type] - - ;; Find relationships for this resource - [?relationship :eacl.relationship/resource ?resource] - [?relationship :eacl.relationship/subject ?subject] - [?relationship :eacl.relationship/relation-name ?relation-name] - - ;; Check subject type - [?subject :resource/type ?subject-type] - - ;; Check permission using tuple - [(tuple ?resource-type ?relation-name ?permission-name) ?perm-tuple] - [?perm-def :eacl.permission/resource-type+relation-name+permission-name ?perm-tuple] - - [(not= ?subject ?resource)]] - - ;; Indirect permission inheritance - [(has-permission ?subject-type ?subject ?permission-name ?resource) - [?resource :resource/type ?resource-type] - - ;; Find permission definitions - [?perm-def :eacl.permission/resource-type ?resource-type] - [?perm-def :eacl.permission/permission-name ?permission-name] - [?perm-def :eacl.permission/relation-name ?relation-name] - - ;; Find structural relationships - [?structural-rel :eacl.relationship/subject ?resource] - [?structural-rel :eacl.relationship/relation-name ?relation-name] - [?structural-rel :eacl.relationship/resource ?target] - - (reachable ?target ?subject) - [?subject :resource/type ?subject-type] - [(not= ?subject ?resource)]] - - ;; Arrow permission - [(has-permission ?subject-type ?subject ?perm-name-on-this-resource ?this-resource) - [?this-resource :resource/type ?this-resource-type] - - ;; Find arrow permissions - [?arrow-perm :eacl.arrow-permission/resource-type ?this-resource-type] - [?arrow-perm :eacl.arrow-permission/permission-name ?perm-name-on-this-resource] - [?arrow-perm :eacl.arrow-permission/source-relation-name ?via-relation] - [?arrow-perm :eacl.arrow-permission/target-permission-name ?perm-on-related] - - ;; Find intermediate - [?rel-linking :eacl.relationship/resource ?this-resource] - [?rel-linking :eacl.relationship/relation-name ?via-relation] - [?rel-linking :eacl.relationship/subject ?intermediate-resource] - - (has-permission ?subject-type ?subject ?perm-on-related ?intermediate-resource) - - [(not= ?subject ?this-resource)] - [(not= ?subject ?intermediate-resource)] - [(not= ?this-resource ?intermediate-resource)]]]) - -(def rules-lookup-resources - "Optimized rules for lookup-resources - subject-centric approach" - '[;; Helper rule: find relationships from subject - [(subject-has-relationships ?subject ?relation ?resource) - ;; Start from subject - - ;[(tuple ?subject ?relation ?resource) ?subject+relation+resource] - ;[?relationship :eacl.relationship/] - - [?relationship :eacl.relationship/subject ?subject] - [?relationship :eacl.relationship/relation-name ?relation] - [?relationship :eacl.relationship/resource ?resource]] - - ;; Direct permission check - subject-centric - [(has-permission ?subject ?permission ?resource-type ?resource) - ;; Start from subject's relationships - (subject-has-relationships ?subject ?relation ?resource) - - ;; Check if resource is of correct type - [?resource :resource/type ?resource-type] - - ;; Check if relation grants permission - [?perm :eacl.permission/resource-type ?resource-type] - [?perm :eacl.permission/relation-name ?relation] - [?perm :eacl.permission/permission-name ?permission]] - - ;; Indirect permission via intermediate resources - [(has-permission ?subject ?permission ?resource-type ?resource) - ;; Find relationships where subject can reach an intermediate - (subject-has-relationships ?subject ?rel1 ?intermediate) - - ;; Find permission definition that grants access via relation - [?perm-def :eacl.permission/resource-type ?resource-type] - [?perm-def :eacl.permission/permission-name ?permission] - [?perm-def :eacl.permission/relation-name ?rel2] - - ;; Find resources connected to intermediate via rel2 - [?relationship2 :eacl.relationship/subject ?intermediate] - [?relationship2 :eacl.relationship/relation-name ?rel2] - [?relationship2 :eacl.relationship/resource ?resource] - - ;; Verify resource type - [?resource :resource/type ?resource-type]] - - ;; Arrow permission - optimized for subject-centric lookup - [(has-permission ?subject ?permission ?resource-type ?resource) - ; known: subject, permission, resource-type. - ;; Find arrow permissions for the target resource type and permission - - [(tuple ?resource-type ?permission) ?rtype+perm] - [?arrow :eacl.arrow-permission/resource-type+permission-name ?rtype+perm] - - ;[?arrow :eacl.arrow-permission/resource-type ?resource-type] - ;[?arrow :eacl.arrow-permission/permission-name ?permission] - [?arrow :eacl.arrow-permission/source-relation-name ?via-rel] - [?arrow :eacl.arrow-permission/target-permission-name ?target-perm] - - ;; Find resources of target type - [?resource :resource/type ?resource-type] ; this looks slow. - - ;; Find intermediate resources linked to target resource (resource is not known here) - ; the problem is we know via-rel, but not ?intermediate or ?resource. - ; how to cull ?resource here. - ; we should be able to narrow down relationships here to find the relevant ?intermediate subjects for traversal - - ;[(tuple ?subject ?via-rel) ?subject+via-rel] - ;[?link :eacl.relationship/subject+relation-name ?subject+via-rel] - - [?link :eacl.relationship/relation-name ?via-rel] - [?link :eacl.relationship/resource ?resource] - [?link :eacl.relationship/subject ?intermediate] - - ;; Get intermediate resource type - [?intermediate :resource/type ?intermediate-type] - - ;; Check if subject has target permission on intermediate (recursive) - (has-permission ?subject ?target-perm ?intermediate-type ?intermediate)]]) \ No newline at end of file diff --git a/modules/eacl-datomic/src/eacl/datomic/schema.clj b/modules/eacl-datomic/src/eacl/datomic/schema.clj index 4cf854db6..ffdc47720 100644 --- a/modules/eacl-datomic/src/eacl/datomic/schema.clj +++ b/modules/eacl-datomic/src/eacl/datomic/schema.clj @@ -188,11 +188,11 @@ (if-not relation-eid 0 (reduce (fn [n _] (inc n)) - 0 - (d/index-range db - :eacl.v7.relationship/subject-type+relation+resource-type+resource - [subject-type relation-eid resource-type 0] - [subject-type relation-eid resource-type Long/MAX_VALUE]))))) + 0 + (d/index-range db + :eacl.v7.relationship/subject-type+relation+resource-type+resource + [subject-type relation-eid resource-type 0] + [subject-type relation-eid resource-type Long/MAX_VALUE]))))) (defn read-relations "Enumerates all EACL Relation schema entities in DB and returns pull maps." @@ -203,7 +203,7 @@ :eacl.relation/relation-name]) ...] :where [?relation :eacl.relation/relation-name ?relation-name]] - db)) + db)) (defn read-permissions "Enumerates all EACL permission schema entities in DB and returns maps." @@ -216,7 +216,7 @@ :eacl.permission/target-name]) ...] :where [?perm :eacl.permission/permission-name]] - db)) + db)) (defn read-schema "Enumerates all EACL permission schema entities in DB and returns maps." @@ -241,28 +241,43 @@ new schema, checks for any orphaned relationships on retracted schema, produces tx-ops and applies. - Throws if schema is invalid (operator validation, reference validation, orphan check)." - [conn schema-string] - (let [new-schema-map (parser/->eacl-schema (parser/parse-schema schema-string)) + Throws if schema is invalid (parse failure, operator validation, reference + validation, orphan check), or if the new schema contains zero definitions + while a non-empty schema is stored (belt-and-braces against parser gaps - + a malformed input must never be able to retract the whole schema). Pass + {:allow-empty-schema? true} to explicitly wipe the stored schema." + ([conn schema-string] + (write-schema! conn schema-string {})) + ([conn schema-string {:keys [allow-empty-schema?]}] + (let [new-schema-map (parser/->eacl-schema (parser/parse-schema schema-string)) ;; Validate schema references before proceeding (ADR 012 requirement) - _ (validate-schema-references new-schema-map) - db (d/db conn) - existing-schema (read-schema db) - deltas (compare-schema existing-schema new-schema-map) - {:keys [relations permissions]} deltas - relation-retractions (:retractions relations) - permission-retractions (:retractions permissions)] + _ (validate-schema-references new-schema-map) + db (d/db conn) + existing-schema (read-schema db) + _ (when (and (empty? (:definitions new-schema-map)) + (not allow-empty-schema?) + (or (seq (:relations existing-schema)) + (seq (:permissions existing-schema)))) + (throw (ex-info (str "Refusing to replace a non-empty schema with zero definitions." + " Pass {:allow-empty-schema? true} to write-schema! if this is intentional.") + {:type :eacl.schema/empty-schema-guard + :existing {:relations (count (:relations existing-schema)) + :permissions (count (:permissions existing-schema))}}))) + deltas (compare-schema existing-schema new-schema-map) + {:keys [relations permissions]} deltas + relation-retractions (:retractions relations) + permission-retractions (:retractions permissions)] ;; Check for orphaned relationships - (doseq [rel relation-retractions] - (let [cnt (count-relationships-using-relation db rel)] - (when (pos? cnt) - (throw (ex-info (str "Cannot delete relation " (:eacl.relation/relation-name rel) - " because it is used by " cnt " relationships.") - {:relation rel :count cnt}))))) + (doseq [rel relation-retractions] + (let [cnt (count-relationships-using-relation db rel)] + (when (pos? cnt) + (throw (ex-info (str "Cannot delete relation " (:eacl.relation/relation-name rel) + " because it is used by " cnt " relationships.") + {:relation rel :count cnt}))))) ;; Transact changes - (let [tx-data (concat + (let [tx-data (concat ;; Additions (:additions relations) (:additions permissions) @@ -274,6 +289,6 @@ ;; Store schema string [{:eacl/id "schema-string" :eacl/schema-string schema-string}])] - @(d/transact conn tx-data) - (impl.indexed/evict-permission-paths-cache!) - deltas))) + @(d/transact conn tx-data) + (impl.indexed/evict-permission-paths-cache!) + deltas)))) diff --git a/modules/eacl-datomic/test/eacl/bench/pagination_test.clj b/modules/eacl-datomic/test/eacl/bench/pagination_test.clj index b9dc645f0..bd9ff1666 100644 --- a/modules/eacl-datomic/test/eacl/bench/pagination_test.clj +++ b/modules/eacl-datomic/test/eacl/bench/pagination_test.clj @@ -62,7 +62,8 @@ (defn- tx-relationships [db relationships] - (mapcat #(impl/tx-relationship db %) relationships)) + ; :allow-tempids? because entities are created in the same transaction. + (mapcat #(impl/tx-relationship db % {:allow-tempids? true}) relationships)) ;; --- Seeding --- diff --git a/modules/eacl-datomic/test/eacl/benchmark_test.clj b/modules/eacl-datomic/test/eacl/benchmark_test.clj deleted file mode 100644 index 63cbdf0b9..000000000 --- a/modules/eacl-datomic/test/eacl/benchmark_test.clj +++ /dev/null @@ -1,403 +0,0 @@ -;(ns eacl.benchmark-test -; (:require [criterium.core :as crit] -; [eacl.core :as eacl] -; [eacl.datomic.core :as spiceomic] -; ; [eacl.datomic.impl-base :as base :refer [Relation Relationship Permission]] -; [eacl.datomic.impl :as impl :refer [Relation Relationship Permission]] -; [eacl.datomic.schema :as schema] -; [datomic.api :as d] -; [eacl.datomic.fixtures :as fixtures :refer [->platform ->account ->user ->server]] -; [clojure.test :as t :refer [deftest testing is]] -; [clojure.tools.logging :as log])) -; -;;(defn rand-subject []) -; -;(defn tx! [conn tx-data] -; ;(prn tx-data) -; @(d/transact conn tx-data)) -; -;(defn ids->tempid-map [uuid-coll] -; (->> uuid-coll -; (reduce (fn [acc uuid] -; (assoc acc uuid (d/tempid :db.part/user))) -; {}))) -; -;(defn make-account-user-txes [account-tempid n] -; (let [user-uuids (repeatedly n d/squuid) -; user-uuid->tempid (ids->tempid-map user-uuids)] -; (for [user-uuid user-uuids] -; (let [user-tempid (user-uuid->tempid user-uuid)] -; [{:db/id user-tempid -; :eacl/id (str user-uuid) -; :user/account account-tempid} ; only to police permission checks. -; (Relationship (->user user-tempid) -; :owner -; (->account account-tempid))])))) -; -;(defn make-account-server-txes [account-tempid n] -; (let [server-uuids (repeatedly n d/squuid) -; server-uuid->tempid (ids->tempid-map server-uuids)] -; -; (for [server-uuid server-uuids] -; (let [server-tempid (server-uuid->tempid server-uuid)] -; [{:db/id server-tempid -; :eacl/id (str server-uuid) -; :server/account account-tempid ; only to police permission checks. -; :server/name (str "Servers " server-uuid)} -; (Relationship (->account account-tempid) :account (->server server-tempid))])))) -; -;(defn make-account-txes [{:keys [num-users num-servers]} account-uuid] -; (let [account-tempid (d/tempid :db.part/user) -; account-txes [{:db/id account-tempid -; :eacl/id (str account-uuid)} -; (Relationship (->platform [:eacl/id "platform"]) :platform (->account account-tempid))] -; user-txes (make-account-user-txes account-tempid num-users) -; server-txes (make-account-server-txes account-tempid num-servers)] -; (concat account-txes (flatten user-txes) (flatten server-txes)))) -; -;(defn server->user-ids [db server-id] -; (d/q '[:find [?user-id ...] -; :in $ ?server-id -; :where -; [?server :eacl/id ?server-id] -; [?server :server/account ?account] -; [?user :user/account ?account] -; [?user :eacl/id ?user-id]] -; db server-id)) -; -;(defn setup-benchmark [db] -; {:accounts (d/q '[:find [?account-id ...] -; :where -; [?server :server/account ?account] -; [?account :eacl/id ?account-id]] -; db) -; :users (d/q '[:find [?user-id ...] -; :where -; [?user :user/account ?account] -; [?user :eacl/id ?user-id]] -; db) -; :servers (d/q '[:find [?server-id ...] -; :where -; [?server :server/account ?account] -; [?server :eacl/id ?server-id]] -; db)}) -; -;(defn run-benchmark [!counter client {:keys [accounts users servers]}] -; ; now we cross-check each user for server and police that the value is correct -; ; do we need to shuffle these for accurate test? -; (doall (for [server-id servers -; user-id users] -; (do -; (swap! !counter inc) -; [user-id server-id (eacl/can? client (->user user-id) :view (->server server-id))])))) -; -;(defn check-results [server->user-set matrix] -; (for [[user-id server-id actual] matrix -; :let [user-set (server->user-set server-id) -; expected (contains? user-set server-id)]] -; [actual expected])) -; -;(defn rand-user [db] -; (d/q '[:find (rand ?user-uuid) . -; :in $ -; :where -; [?user :user/account ?account] -; [?user :eacl/id ?user-uuid]] -; db)) -; -;(defn rand-server [db] -; (d/q '[:find (rand ?server-uuid) . -; :in $ -; :where -; [?server :server/account ?account] -; [?server :eacl/id ?server-uuid]] -; db)) -; -;(deftest eacl-benchmarks -; ; todo switch to with-mem-conn. -; ;(def datomic-uri "datomic:dev://localhost:4597/eacl-benchmark") -; -; (comment -; (def datomic-uri "datomic:mem://mem-eacl-benchmark") -; (d/delete-database datomic-uri) -; (d/create-database datomic-uri) -; (def conn (d/connect datomic-uri)) -; (.release conn) -; #_[]) -; -; (comment -; -; (testing "Transact EACL Datomic Schema" -; (tx! conn (concat schema/v5-schema))) -; -; (testing "Transact a realistic EACL Permission Schema" -; (tx! conn fixtures/base-fixtures)) -; -; (testing "some schema to police our data" -; (tx! conn [{:db/ident :server/name -; :db/doc "Just to add some real data into the mix." -; :db/cardinality :db.cardinality/one -; :db/valueType :db.type/string -; :db/index true} -; -; {:db/ident :user/account -; :db/cardinality :db.cardinality/many -; :db/valueType :db.type/ref -; :db/index true} -; -; {:db/ident :server/account -; :db/cardinality :db.cardinality/one -; :db/valueType :db.type/ref -; :db/index true}])) -; -; (def test-account (d/q '[:find (rand ?account-uuid) . -; :where -; [?server :server/account ?account] -; [?account :eacl/id ?account-uuid]] -; (d/db conn))) -; -; test-account -; -; (def test-user (d/q '[:find (rand ?user-uuid) . -; :in $ ?account-uuid -; :where -; [?user :user/account ?account] -; [?user :eacl/id ?user-uuid]] -; (d/db conn) test-account)) -; -; (def client (spiceomic/make-client conn {})) -; -; ;; Add platform relations for all accounts: -; -; (let [platform-id (d/entid (d/db conn) [:eacl/id "platform"])] -; (->> (d/q '[:find [?account ...] -; :where [?server :server/account ?account]] -; (d/db conn)) -; (map (fn [acc] -; (Relationship (->platform platform-id) :platform (->account acc)))) -; (d/transact conn) -; (deref))) -; -; (time (count (:data (eacl/lookup-resources client {:subject (->user "super-user") -; :permission :view -; :resource/type :server -; :cursor nil -; :limit 1000})))) -; -; (time (count (:data (eacl/lookup-resources client {:subject (->user "super-user") -; :permission :view -; :resource/type :server -; :cursor nil -; :limit 100000000})))) -; -; (time (count (:data (eacl/lookup-resources client {:subject (->user "super-user") -; :permission :view -; :resource/type :server -; :cursor nil -; :limit 1000})))) -; -; (let [test-user (rand-user (d/db conn))] -; (let [{:as page1 -; p1-data :data -; p1-cursor :cursor} -; (eacl/lookup-resources client {:subject (->user test-user) -; :permission :view -; :resource/type :server -; :cursor nil -; :limit 600}) -; page1-count (count p1-data) -; -; {:as page2 -; p2-data :data -; p2-cursor :cursor} -; (eacl/lookup-resources client {:subject (->user test-user) -; :permission :view -; :resource/type :server -; :cursor p1-cursor -; :limit 400}) -; page2-count (count p2-data) -; -; {:as page3 -; p3-data :data -; p3-cursor :cursor} -; (eacl/lookup-resources client {:subject (->user test-user) -; :permission :view -; :resource/type :server -; :cursor p2-cursor -; :limit 100}) -; page3-count (count p3-data) -; -; total-count (+ page1-count page2-count page3-count) -; all-pages-data (concat p1-data p2-data p3-data) -; unique-count (count (distinct all-pages-data))] -; (assert (> total-count 700)) -; {:total/count total-count -; :count [page1-count page2-count page3-count] -; :cursors [p1-cursor p2-cursor p3-cursor] -; :data (concat p1-data p2-data p3-data) -; :unique-count unique-count})) -; -; (let [test-user (rand-user (d/db conn))] -; ; fetch two pages of data (we are not checking correctness here) -; (let [{:as page1 -; data :data -; p1-cursor :cursor} -; (eacl/lookup-resources client {:subject (->user test-user) -; :permission :view -; :resource/type :server -; :cursor nil -; :limit 600}) -; c1 (count data) -; -; {:as page2 -; data :data -; p2-cursor :cursor} -; (eacl/lookup-resources client {:subject (->user test-user) -; :permission :view -; :resource/type :server -; :cursor p1-cursor -; :limit 400}) -; c2 (count data)] -; [p1-cursor p2-cursor])) -; -; (eacl/count-resources client {:subject (->user "super-user") -; :permission :view -; :resource/type :server -; :cursor nil}) -; -; (crit/quick-bench -; (let [page (eacl/lookup-resources client {:subject (->user "super-user") -; :permission :view -; :resource/type :server -; :cursor nil -; :limit 1000000000})])) -; -; (crit/quick-bench -; (let [test-user (rand-user (d/db conn))] -; ; fetch two pages of data (we are not checking correctness here) -; (let [{:as page1 :keys [data cursor]} -; (eacl/lookup-resources client {:subject (->user test-user) -; :permission :view -; :resource/type :server -; :cursor nil -; :limit 600}) -; c1 (count data) -; -; {:as page2 :keys [data cursor]} -; (eacl/lookup-resources client {:subject (->user test-user) -; :permission :view -; :resource/type :server -; :cursor cursor -; :limit 400}) -; c2 (count data)] -; nil))) -; -; (let [test-server (rand-server (d/db conn))] -; (prn 'test-server test-server) -; (time (count (eacl/lookup-subjects client {:resource (->server test-server) -; :permission :view -; :subject/type :user})))) -; -; (time (count (eacl/read-relationships client {:resource/type :account}))) -; (time (count (eacl/read-relationships client {:resource/type :server}))) -; ()) -; -; ; Transact Test Data -; (let [num-accounts 100 -; num-users 10 -; num-servers 1000 -; account-uuids (repeatedly num-accounts d/squuid) -; account-txes (time (->> account-uuids -; (mapv (partial make-account-txes {:num-users num-users -; :num-servers num-servers})) -; (flatten))) -; tx-count (count account-txes)] -; ;(log/warn "Skipping txe.") -; (log/debug "Transacting " tx-count " things.") -; (tx! conn account-txes) -; -; (let [!counter (atom 0) -; !mistakes (atom 0) -; client (spiceomic/make-client conn {}) -; db (d/db conn) -; {:as setup :keys [accounts users servers]} (time (setup-benchmark db)) -; _ (do (log/debug "N accounts" (count accounts)) -; (log/debug "N users" (count users)) -; (log/debug "N servers" (count servers))) -; server->user-set (time (into {} -; (for [server-id servers] -; [server-id (set (server->user-ids db server-id))]))) -; server->users (time (into {} -; (for [server-id servers] -; [server-id (vec (server->user-ids db server-id))])))] -; ;(prn 'server->users server->users) -; (when false ; true ; false ; do -; (log/debug "Starting benchmark...") -; (crit/quick-bench -; (let [random-server (rand-nth servers) -; expected-userset (server->user-set random-server) -; expected-user-list (server->users random-server) -; ;_ (prn 'expected-user-list expected-user-list) -; random-user (if (and (>= (rand) 0.5) (seq expected-user-list)) ; some empty -; (rand-nth expected-user-list) -; (rand-nth users)) -; expected (contains? expected-userset random-user) -; _ (swap! !counter inc) -; actual (eacl/can? client (->user random-user) :view (->server random-server))] -; ;(log/debug expected random-user random-server) -; (when (not= expected actual) -; (swap! !mistakes inc)) -; [expected actual])) -; (prn 'counter @!counter 'mistakes @!mistakes))))) -; -;;(let [result-matrix (time (run-benchmark !counter client setup)) -;; checks (check-results server->user-set result-matrix) -;; matches (map (fn [[actual expected]] -;; (= actual expected)) checks) -;; disparities (frequencies matches)] -;; (log/debug 'disparities disparities) -;; (log/debug 'counter @!counter) -;; disparities)))) -; -;(comment -; ; ok so we have 100 accounts, 10 users per account, and 1000 servers per account -; ; th ameans we ahve 100 * 1000 = 100,000 servers. -; ; total users = 10 * 100 = 1,000 users -; ; users * servers = 100,000 * 1,000 = 100,000,000 M permission checks. -; -; (let [db (d/db conn) -; ; pull some relations -; users-cos (d/q '[:find ?user ?company -; :where -; [?user :user/username] -; [?rel :eacl/subject ?user] -; [?rel :eacl/relation :company/owner] -; [?rel :eacl/resource ?company]] -; db)] -; (prn (count users-cos) 'users-cos) -; (time -; (doall (frequencies (->> users-cos (pmap (fn [[user company]] -; (eacl/can? db user :company/view company)))))))) -; -; (let [subjects (d/q '[:find [?subject ...] -; :where -; [?subject :eacl/subject]] -; (d/db conn)) -; subject (rand-nth subjects)])) -;;(prn 'can? (eacl/can? (d/db conn) (:db/id subject) :company/view [:eacl/id (first cids)])))) -; -;(comment -; (d/q '[:find (count ?account) . -; :where -; [?account :eacl/type :account]] -; (d/db conn)) -; -; (d/q '[:find (count ?server) . -; :where -; [?server :eacl/type :server]] -; (d/db conn)) -; -; (d/q '[:find (count ?user) . -; :where -; [?user :eacl/type :user]] -; (d/db conn))) diff --git a/modules/eacl-datomic/test/eacl/datomic/config_test.clj b/modules/eacl-datomic/test/eacl/datomic/config_test.clj index d19bfab61..7c4ea59ee 100644 --- a/modules/eacl-datomic/test/eacl/datomic/config_test.clj +++ b/modules/eacl-datomic/test/eacl/datomic/config_test.clj @@ -28,13 +28,13 @@ ; todo: also test read/write-relationships, and count-resources. - (testing "lookup-resources throws for missing subject ident with some detail" - (is (thrown? Throwable (eacl/lookup-resources client - {:subject (->user :missing-ident) - :permission :view - :resource/type :server - :limit 1000 - :cursor nil})))) + (testing "lookup-resources returns an empty page for a missing subject ident (SpiceDB-consistent, audit D9)" + (is (= [] (:data (eacl/lookup-resources client + {:subject (->user :missing-ident) + :permission :view + :resource/type :server + :limit 1000 + :cursor nil}))))) (testing "basic can? works when passing :db/ident" (is (true? (eacl/can? client (->user :test/user1) :view (->server :test/server1)))) diff --git a/modules/eacl-datomic/test/eacl/datomic/differential_test.clj b/modules/eacl-datomic/test/eacl/datomic/differential_test.clj new file mode 100644 index 000000000..f3abea421 --- /dev/null +++ b/modules/eacl-datomic/test/eacl/datomic/differential_test.clj @@ -0,0 +1,152 @@ +(ns eacl.datomic.differential-test + "Seeded randomized differential tests codifying the audit's cross-engine + invariant: for every (subject, permission, resource-type), + + lookup-resources set == can?-derived ground truth + == paginated union at several page sizes + == count-resources + + and the reverse via lookup-subjects. Hand-rolled seeded RNG — no new deps. + These invariants held for the engines during the 2026-07-06 audit; this + makes them executable against every future change." + (:require [clojure.test :refer [deftest testing is]] + [datomic.api :as d] + [eacl.core :refer [spice-object]] + [eacl.datomic.datomic-helpers :refer [with-mem-conn]] + [eacl.datomic.impl :as impl :refer [Relationship]] + [eacl.datomic.impl.indexed :as idx] + [eacl.datomic.schema :as schema])) + +(def ^:private differential-schema + "Exercises direct relations, arrow->permission, arrow->relation, + self-permission, and overlapping multi-path unions." + "definition user {} + + definition platform { + relation super_admin: user + } + + definition account { + relation owner: user + relation platform: platform + + permission admin = owner + platform->super_admin + } + + definition server { + relation account: account + relation shared: user + + permission admin = account->admin + shared + permission view = admin + shared + }") + +(defn- rand-subset + [^java.util.Random rng coll p] + (vec (filter (fn [_] (< (.nextDouble rng) p)) coll))) + +(defn- entity-txes + [ids] + (mapv (fn [id] {:db/id id :eacl/id id}) ids)) + +(defn- eid-of [db id] (d/entid db [:eacl/id id])) + +(defn- collect-paged + "Collects a full paginated enumeration at the given page size." + [db query page-size] + (loop [cursor nil + acc []] + (let [page (idx/lookup-resources db (assoc query :limit page-size :cursor cursor)) + acc' (into acc (map :id (:data page)))] + (if (seq (:data page)) + (recur (:cursor page) acc') + acc')))) + +(defn- check-forward-invariants! + [db label subject permission resource-type all-resource-eids sorted?] + (let [query {:subject subject :permission permission :resource/type resource-type} + full (mapv :id (:data (idx/lookup-resources db (assoc query :limit -1)))) + truth (set (filter #(idx/can? db subject permission (spice-object resource-type %)) + all-resource-eids))] + (is (= truth (set full)) + (str label ": lookup-resources set must equal can? ground truth")) + (is (= (count full) (count (distinct full))) + (str label ": no duplicates")) + (when sorted? + (is (= full (sort full)) + (str label ": non-recursive results are in ascending eid order"))) + (doseq [page-size [1 3 7]] + (is (= full (collect-paged db query page-size)) + (str label ": paginated union at page size " page-size " must equal the full enumeration"))) + (is (= (count full) + (:count (idx/count-resources db (assoc query :limit -1)))) + (str label ": count-resources must agree")) + full)) + +(defn- check-reverse-invariants! + [db label resource permission subject-type all-subject-eids] + (let [subjects (mapv :id (:data (idx/lookup-subjects db {:resource resource + :permission permission + :subject/type subject-type + :limit -1}))) + truth (set (filter #(idx/can? db (spice-object subject-type %) permission resource) + all-subject-eids))] + (is (= truth (set subjects)) + (str label ": lookup-subjects set must equal can? ground truth")) + (is (= (count subjects) (count (distinct subjects))) + (str label ": no duplicate subjects")))) + +(deftest differential-nonrecursive-test + (doseq [seed [7 23 42 1337]] + (with-mem-conn [conn schema/v6-schema] + (let [rng (java.util.Random. (long seed)) + users (mapv #(str "user-" %) (range 3)) + accounts (mapv #(str "acct-" %) (range 3)) + servers (mapv #(str "srv-" %) (range 12)) + platform "platform-1"] + (schema/write-schema! conn differential-schema) + @(d/transact conn (entity-txes (concat users accounts servers [platform]))) + (let [db0 (d/db conn) + rels (concat + ;; platform super admins + (for [u (rand-subset rng users 0.3)] + (Relationship (spice-object :user u) :super_admin (spice-object :platform platform))) + ;; account owners + platform membership + (mapcat (fn [a] + (concat + (for [u (rand-subset rng users 0.5)] + (Relationship (spice-object :user u) :owner (spice-object :account a))) + (when (< (.nextDouble rng) 0.5) + [(Relationship (spice-object :platform platform) :platform (spice-object :account a))]))) + accounts) + ;; servers: account membership + direct shares + (mapcat (fn [s] + (concat + (when (< (.nextDouble rng) 0.8) + [(Relationship (spice-object :account (nth accounts (.nextInt rng (count accounts)))) + :account (spice-object :server s))]) + (for [u (rand-subset rng users 0.15)] + (Relationship (spice-object :user u) :shared (spice-object :server s))))) + servers))] + @(d/transact conn (into [] (mapcat #(impl/tx-relationship db0 %)) rels))) + (let [db (d/db conn) + server-eids (mapv #(eid-of db %) servers) + account-eids (mapv #(eid-of db %) accounts) + user-eids (mapv #(eid-of db %) users)] + (testing (str "seed " seed ": forward invariants for every user × permission") + (doseq [u users + [perm rt eids] [[:view :server server-eids] + [:admin :server server-eids] + [:admin :account account-eids]]] + (check-forward-invariants! db (str "seed " seed " user " u " " perm " " rt) + (spice-object :user (eid-of db u)) + perm rt eids true))) + (testing (str "seed " seed ": reverse invariants for every server") + (doseq [s servers] + (check-reverse-invariants! db (str "seed " seed " server " s) + (spice-object :server (eid-of db s)) + :view :user user-eids)))))))) + +;; NOTE: the recursive-schema differential test from the Datomic-peer lineage is +;; omitted: this branch's shared engine intentionally prunes cyclic permission +;; graphs during path calculation (no recursive frontier engine here yet). diff --git a/modules/eacl-datomic/test/eacl/datomic/fixtures.clj b/modules/eacl-datomic/test/eacl/datomic/fixtures.clj index a3b95526d..c3c4a5fba 100644 --- a/modules/eacl-datomic/test/eacl/datomic/fixtures.clj +++ b/modules/eacl-datomic/test/eacl/datomic/fixtures.clj @@ -352,7 +352,8 @@ (defn relationship-fixtures [db] - (mapcat #(impl/tx-relationship db %) relationship-fixture-data)) + ; :allow-tempids? because entity fixtures land in the same transaction. + (mapcat #(impl/tx-relationship db % {:allow-tempids? true}) relationship-fixture-data)) (defn base-fixtures [db] @@ -372,7 +373,7 @@ {:db/id "account-3" :db/ident :test/account3 :eacl/id "account-3"}] - (mapcat #(impl/tx-relationship db %) + (mapcat #(impl/tx-relationship db % {:allow-tempids? true}) [(Relationship (->account "account-3") :account (->server "account3-server3.1")) (Relationship (->user :test/user1) :owner (->account "account-3"))]))) diff --git a/modules/eacl-datomic/test/eacl/datomic/impl/indexed_test.clj b/modules/eacl-datomic/test/eacl/datomic/impl/indexed_test.clj index 2a0a24d3f..8c7254072 100644 --- a/modules/eacl-datomic/test/eacl/datomic/impl/indexed_test.clj +++ b/modules/eacl-datomic/test/eacl/datomic/impl/indexed_test.clj @@ -257,7 +257,8 @@ bulk-ids) (mapcat (fn [id] (impl/tx-relationship db - (Relationship (->user id) :owner (->account :test/account1)))) + (Relationship (->user id) :owner (->account :test/account1)) + {:allow-tempids? true})) bulk-ids)) db' (:db-after (d/with db tx-data)) {page-1 :data cursor :cursor} @@ -449,7 +450,7 @@ (is (can? db' (->user (d/entid db' [:eacl/id "user-1"])) :view (->server [:eacl/id "account2-server1"]))) (is (can? db' (->user (d/entid db' [:eacl/id "super-user"])) :view (->server [:eacl/id "account2-server1"]))) - (is (not (can? db' (->user (d/entid db' [:eacl/id "user2"])) :view (->server [:eacl/id "account2-server1"])))) + (is (not (can? db' (->user (d/entid db' [:eacl/id "user-2"])) :view (->server [:eacl/id "account2-server1"])))) (testing ":test/user2 cannot access any servers" ; is this correct? (is (= #{} (->> (lookup-resources db' {:resource/type :server @@ -527,9 +528,11 @@ (Relationship (->user :user/super-user) :shared_admin (->server :test/server1)))) ; We can use tempids in Relationship because tuple tx-data keeps the tempid. (first (impl/tx-relationship (d/db *conn*) - (Relationship (->user :user/super-user) :shared_admin (->server "server3")))) + (Relationship (->user :user/super-user) :shared_admin (->server "server3")) + {:allow-tempids? true})) (second (impl/tx-relationship (d/db *conn*) - (Relationship (->user :user/super-user) :shared_admin (->server "server3"))))]))) + (Relationship (->user :user/super-user) :shared_admin (->server "server3")) + {:allow-tempids? true}))]))) (let [db' (d/db *conn*)] (testing "ensure user1 can only see servers from account1, so excludes server-3" @@ -1171,3 +1174,66 @@ (is (= 2 (count @impl.indexed/permission-paths-cache)) "Permission path caching must not leak DB-specific relation eids across databases")))) + +(deftest tx-relationship-strictness-test + ;; Audit 12: silent tempid pass-through minted ghost entities on typo'd ids. + (with-mem-conn [conn schema/v6-schema] + @(d/transact conn [(Relation :account :owner :user)]) + @(d/transact conn [{:eacl/id "alice"} {:eacl/id "acct-1"}]) + (let [db (d/db conn)] + (testing "a typo'd string id throws :eacl/unknown-object instead of minting a ghost entity" + (is (thrown-with-msg? clojure.lang.ExceptionInfo #"Unknown object" + (impl/tx-relationship db + (Relationship (spice-object :user "alice") :owner (spice-object :account "acct-1x")))))) + + (testing "unallocated positive numeric eids are rejected with the typed error" + (is (thrown-with-msg? clojure.lang.ExceptionInfo #"Unknown object" + (impl/tx-relationship db + (Relationship (spice-object :user 17592186999999) :owner (spice-object :account [:eacl/id "acct-1"])))))) + + (testing "{:allow-tempids? true} supports same-transaction entity+relationship creation" + (let [tx (concat [{:db/id "new-user" :eacl/id "new-user"}] + (impl/tx-relationship db + (Relationship (spice-object :user "new-user") :owner (spice-object :account [:eacl/id "acct-1"])) + {:allow-tempids? true})) + {:keys [db-after]} @(d/transact conn tx)] + (is (impl/find-one-relationship-id db-after + {:subject (spice-object :user [:eacl/id "new-user"]) + :relation :owner + :resource (spice-object :account [:eacl/id "acct-1"])}))))))) + +(deftest relation-datoms-keyword-collation-test + ;; Audit 2: the old [:a]..[:z] index-range made relations whose subject-type + ;; keyword collates outside that window invisible to permission evaluation. + (with-mem-conn [conn schema/v6-schema] + @(d/transact conn [(Relation :zone :owner :zebra) + (Relation :zone :editor :Admin) + (Relation :zone :viewer :my.app/user) + (Relation :zone :ownerx :user) + (Permission :zone :admin {:relation :owner})]) + @(d/transact conn [{:db/id "z1" :eacl/id "zebra-1"} + {:db/id "zone1" :eacl/id "zone-1"}]) + @(d/transact conn (impl/tx-relationship (d/db conn) + (Relationship (spice-object :zebra [:eacl/id "zebra-1"]) + :owner + (spice-object :zone [:eacl/id "zone-1"])))) + (let [db (d/db conn)] + (testing "relations are visible for any legal subject-type keyword" + (is (= [[:zone :editor :Admin]] (mapv :v (impl.indexed/relation-datoms db :zone :editor)))) + (is (= [[:zone :viewer :my.app/user]] (mapv :v (impl.indexed/relation-datoms db :zone :viewer))))) + + (testing "prefix isolation: (:zone :owner) does not match (:zone :ownerx) or later attributes" + (is (= [[:zone :owner :zebra]] (mapv :v (impl.indexed/relation-datoms db :zone :owner))))) + + (testing "end-to-end: permission evaluation works for a :zebra subject" + (let [zebra (spice-object :zebra (d/entid db [:eacl/id "zebra-1"])) + zone (spice-object :zone (d/entid db [:eacl/id "zone-1"]))] + (is (true? (impl.indexed/can? db zebra :admin zone))) + (is (= [(spice-object :zone "zone-1")] + (paginated->spice db (lookup-resources db {:subject zebra + :permission :admin + :resource/type :zone})))) + (is (= [(spice-object :zebra "zebra-1")] + (paginated->spice db (lookup-subjects db {:resource zone + :permission :admin + :subject/type :zebra}))))))))) diff --git a/modules/eacl-datomic/test/eacl/datomic/parser_test.clj b/modules/eacl-datomic/test/eacl/datomic/parser_test.clj index 9a4829cac..49c75729b 100644 --- a/modules/eacl-datomic/test/eacl/datomic/parser_test.clj +++ b/modules/eacl-datomic/test/eacl/datomic/parser_test.clj @@ -1,9 +1,15 @@ -(ns eacl.datomic.parser_test +(ns eacl.datomic.parser-test + ;; ns renamed from eacl.datomic.parser_test: the cognitect test-runner default + ;; pattern #".*-test$" did not match the underscore name, so these tests were + ;; silently excluded from `clj -X:test` runs. (:require [clojure.test :as t :refer [deftest testing is]] [instaparse.core :as insta] [eacl.spicedb.parser :as parser] [eacl.datomic.impl :as impl])) +(defn- ex-type [f] + (try (f) nil (catch clojure.lang.ExceptionInfo e (:type (ex-data e))))) + (def example-schema-string "definition user {} @@ -152,4 +158,101 @@ (testing ".all() arrow function is rejected during validation" (let [schema "definition doc { relation group: group permission view = group.all(member) }"] (is (thrown-with-msg? clojure.lang.ExceptionInfo #"Unsupported function: \.all\(\)" - (parser/->eacl-schema (parser/parse-schema schema))))))) \ No newline at end of file + (parser/->eacl-schema (parser/parse-schema schema))))))) + +(deftest parse-failure-safety-tests + (testing "a failed parse throws a typed error and never coerces to an empty schema" + (is (= :eacl.schema/parse-error + (ex-type #(parser/->eacl-schema (parser/parse-schema "definition user {"))))) + (testing "the error carries instaparse failure detail (line/column)" + (try + (parser/->eacl-schema (parser/parse-schema "definition user { relation owner user }")) + (is false "should have thrown") + (catch clojure.lang.ExceptionInfo e + (is (= :eacl.schema/parse-error (:type (ex-data e)))) + (is (:failure (ex-data e))))))) + + (testing "transform-schema throws on non-schema input instead of returning nil" + (is (= :eacl.schema/parse-error + (ex-type #(parser/transform-schema (parser/parse-schema "definition user {"))))))) + +(deftest comment-support-tests + (testing "// line comments and /* */ block comments are whitespace" + (let [commented "// leading comment + definition user {} + /* block + comment */ + definition account { + relation owner: user // trailing comment + permission admin = owner /* inline */ + owner + }" + plain "definition user {} + definition account { + relation owner: user + permission admin = owner + owner + }" + parse #(parser/->eacl-schema (parser/parse-schema %))] + (is (= (parse plain) (parse commented))))) + + (testing "comment-only input is still a parse error (a schema needs definitions)" + (is (= :eacl.schema/parse-error + (ex-type #(parser/->eacl-schema (parser/parse-schema "// nothing here"))))))) + +(deftest duplicate-declaration-tests + (testing "duplicate definition blocks are rejected, not silently last-won" + (is (= :eacl.schema/duplicate-definition + (ex-type #(parser/->eacl-schema + (parser/parse-schema "definition user {} + definition account { relation owner: user } + definition account { relation viewer: user }")))))) + + (testing "duplicate relation declarations within a definition are rejected" + (is (= :eacl.schema/duplicate-relation + (ex-type #(parser/->eacl-schema + (parser/parse-schema "definition user {} + definition doc { relation owner: user relation owner: user }")))))) + + (testing "a multi-type relation declared once with | is not a duplicate" + (is (= 2 (count (:relations (parser/->eacl-schema + (parser/parse-schema "definition user {} + definition group {} + definition doc { relation owner: user | group }"))))))) + + (testing "a permission sharing a name with a relation on the same definition is rejected" + (is (= :eacl.schema/name-collision + (ex-type #(parser/->eacl-schema + (parser/parse-schema "definition user {} + definition doc { relation x: user permission x = x }"))))))) + +(deftest paren-expression-tests + (testing "parenthesized union operands flatten to their components" + (let [parse #(parser/->eacl-schema (parser/parse-schema %)) + paren (parse "definition user {} + definition d { relation owner: user relation editor: user + permission manage = (owner + editor) }") + plain (parse "definition user {} + definition d { relation owner: user relation editor: user + permission manage = owner + editor }")] + (is (= (set (:permissions plain)) (set (:permissions paren)))) + (testing "nested parens and mixed operands also flatten" + (is (= (set (:permissions plain)) + (set (:permissions (parse "definition user {} + definition d { relation owner: user relation editor: user + permission manage = ((owner)) + (editor) }")))))))) + + (testing "parenthesized arrow bases are rejected with a clear validation error, not an AssertionError" + (is (thrown-with-msg? clojure.lang.ExceptionInfo #"Parenthesized expressions" + (parser/->eacl-schema + (parser/parse-schema "definition user {} + definition d { relation a: user relation b: user + permission p = (a + b)->c }")))))) + +(deftest arrow-target-kind-tests + (testing "arrow target resolving to mixed kinds across subject types is rejected" + ;; mgmt is a RELATION on user but a PERMISSION on group. + (is (= :eacl.schema/mixed-arrow-target + (ex-type #(parser/->eacl-schema + (parser/parse-schema "definition user { relation mgmt: user } + definition group { relation lead: user permission mgmt = lead } + definition account { relation owner: user | group + permission admin = owner->mgmt }"))))))) \ No newline at end of file diff --git a/modules/eacl-datomic/test/eacl/datomic/performance_test.clj b/modules/eacl-datomic/test/eacl/datomic/performance_test.clj deleted file mode 100644 index 068e514aa..000000000 --- a/modules/eacl-datomic/test/eacl/datomic/performance_test.clj +++ /dev/null @@ -1,221 +0,0 @@ -;(ns eacl.datomic.performance-test -; "Performance benchmarks for EACL optimizations" -; (:require [clojure.test :as t :refer [deftest testing is]] -; [datomic.api :as d] -; [eacl.datomic.datomic-helpers :refer [with-mem-conn]] -; [eacl.datomic.fixtures :as fixtures :refer [->user ->server ->account ->vpc]] -; [eacl.core :as eacl :refer [spice-object]] -; [eacl.datomic.schema :as schema] -; [eacl.datomic.impl :as impl :refer [Relation Relationship Permission]] -; [eacl.datomic.rules :as original-rules] -; [eacl.datomic.rules.optimized :as rules] -; [clojure.tools.logging :as log])) -; -;(defn measure-time -; "Measure execution time of a function in milliseconds" -; [f] -; (let [start (System/nanoTime) -; result (f) -; end (System/nanoTime) -; duration-ms (/ (- end start) 1000000.0)] -; {:result result -; :time-ms duration-ms})) -; -;(defn generate-test-data -; "Generate test data with specified number of users, accounts, and servers" -; [conn num-users num-accounts num-servers prefix] -; (let [users (for [i (range num-users)] -; {:db/id (str prefix "-user-" i) -; :entity/id (str prefix "-user-" i) -; :resource/type :user}) -; -; accounts (for [i (range num-accounts)] -; {:db/id (str prefix "-account-" i) -; :entity/id (str prefix "-account-" i) -; :resource/type :account}) -; -; servers (for [i (range num-servers)] -; {:db/id (str prefix "-server-" i) -; :entity/id (str prefix "-server-" i) -; :resource/type :server}) -; -; ;; Create relationships -; ;; Each user owns an account -; user-account-rels (for [i (range (min num-users num-accounts))] -; (Relationship (->user (str prefix "-user-" i)) -; :owner -; (->account (str prefix "-account-" i)))) -; -; ;; Each account has servers -; servers-per-account (quot num-servers num-accounts) -; account-server-rels (for [i (range num-accounts) -; j (range servers-per-account)] -; (Relationship (->account (str prefix "-account-" i)) -; :account -; (->server (str prefix "-server-" (+ (* i servers-per-account) j)))))] -; -; @(d/transact conn (concat users accounts servers -; user-account-rels account-server-rels)))) -; -;(defn run-performance-comparison -; "Run performance comparison between original and optimized rules" -; [db test-name query-fn original-rules optimized-rules] -; (log/debug (str "\n" test-name ":")) -; -; ;; Test with original rules -; (let [{:keys [time-ms result]} (measure-time #(query-fn db original-rules))] -; (log/debug (format " Original: %.2f ms (found %d results)" -; time-ms (count result)))) -; -; ;; Test with optimized rules -; (let [{:keys [time-ms result]} (measure-time #(query-fn db optimized-rules))] -; (log/debug (format " Optimized: %.2f ms (found %d results)" -; time-ms (count result))))) -; -;(deftest performance-comparison-test -; (testing "Performance comparison between original and optimized rules" -; (with-mem-conn [conn schema/v5-schema] -; ;; Set up base schema -; @(d/transact conn fixtures/base-fixtures) -; -; ;; Generate larger test dataset -; (log/debug "\nGenerating test data...") -; (generate-test-data conn 100 20 500 "perf1") -; -; (let [db (d/db conn)] -; -; ;; Test can? performance -; (run-performance-comparison -; db "can? check (direct permission)" -; (fn [db rules] -; (let [subject (d/entity db [:entity/id "perf1-user-0"]) -; resource (d/entity db [:entity/id "perf1-server-0"])] -; (log/debug 'subject subject 'resource resource) -; (d/q '[:find ?subject -; :in $ % ?subject ?perm ?resource -; :where -; (has-permission ?subject ?perm ?resource)] -; db rules -; (:db/id subject) -; :view -; (:db/id resource)))) -; original-rules/check-permission-rules -; rules/check-permission-rules) -; -; ;; Test lookup-subjects performance -; (run-performance-comparison -; db "lookup-subjects (find who can view server-0)" -; (fn [db rules] -; (let [resource (d/entity db [:entity/id "perf1-server-0"])] -; (d/q '[:find [?subject ...] -; :in $ % ?subject-type ?permission ?resource-eid -; :where -; (has-permission ?subject-type ?subject ?permission ?resource-eid) -; [(not= ?subject ?resource-eid)]] -; db rules -; :user -; :view -; (:db/id resource)))) -; original-rules/rules-lookup-subjects -; rules/rules-lookup-subjects) -; -; ;; Test lookup-resources performance (highest priority) -; (run-performance-comparison -; db "lookup-resources (find servers user-0 can view)" -; (fn [db rules] -; (let [subject (d/entity db [:entity/id "perf1-user-0"])] -; (d/q '[:find [?resource ...] -; :in $ % ?subject-type ?subject-eid ?permission ?resource-type -; :where -; (has-permission ?subject-type ?subject-eid ?permission ?resource-type ?resource)] -; db rules -; :user -; (:db/id subject) -; :view -; :server))) -; original-rules/rules-lookup-resources -; rules/rules-lookup-resources) -; -; ;; Test with larger dataset -; (log/debug "\n\nGenerating larger test dataset...") -; (generate-test-data conn 500 100 2000 "perf2") -; (let [db-large (d/db conn)] -; -; (log/debug "\nLarger dataset tests:") -; -; ;; Test lookup-resources with larger dataset -; (run-performance-comparison -; db-large "lookup-resources on larger dataset" -; (fn [db rules] -; (let [subject (d/entity db [:entity/id "perf2-user-10"])] -; (d/q '[:find [?resource ...] -; :in $ % ?subject-type ?subject-eid ?permission ?resource-type -; :where -; (has-permission ?subject-eid ?permission ?resource-type ?resource) -; [?resource :resource/type ?resource-type]] -; db rules -; :user -; (:db/id subject) -; :view -; :server))) -; original-rules/rules-lookup-resources -; rules/rules-lookup-resources)))))) -; -;(deftest staged-lookup-resources-test -; (testing "Staged lookup-resources implementation" -; (with-mem-conn [conn schema/v5-schema] -; @(d/transact conn fixtures/base-fixtures) -; (generate-test-data conn 100 20 100000 "staged") -; -; (let [db (d/db conn)] -; (log/debug "\n\nStaged lookup-resources test:") -; -; ;; Test original implementation -; (let [{:keys [time-ms result]} -; (measure-time -; #(impl/lookup-resources db {:resource/type :server -; :permission :view -; :subject (->user "staged-user-5") -; :limit 5000000}))] -; (log/debug (format " Full implementation: %.2f ms (found %d results)" -; time-ms (count result))))))) -; -; (testing "Staged lookup-resources with limit & offset implementation" -; (with-mem-conn [conn schema/v5-schema] -; @(d/transact conn fixtures/base-fixtures) -; (generate-test-data conn 100 20 100000 "staged") -; -; (let [db (d/db conn)] -; (log/debug "\n\nStaged lookup-resources test with limit & offset:") -; -; ;; Test original implementation -; (let [{:keys [time-ms result]} -; (measure-time -; #(impl/lookup-resources db {:offset 2000 -; :limit 1500 -; :resource/type :server -; :permission :view -; :subject (->user "staged-user-5")}))] -; (log/debug (format " Full implementation: %.2f ms (found %d results)" -; time-ms (count result))))))) -; -; (testing "Staged lookup-resources with small limit, large offset" -; (with-mem-conn [conn schema/v5-schema] -; @(d/transact conn fixtures/base-fixtures) -; (generate-test-data conn 100 20 100000 "staged") -; -; (let [db (d/db conn)] -; (log/debug "\n\nStaged lookup-resources test with small limit, large offset:") -; -; ;; Test original implementation -; (let [{:keys [time-ms result]} -; (measure-time -; #(impl/lookup-resources db {:offset 2000 -; :limit 20 -; :resource/type :server -; :permission :view -; :subject (->user "staged-user-5")}))] -; (log/debug (format " Full implementation: %.2f ms (found %d results)" -; time-ms (count result)))))))) -; -;;; Run with: clj -M:test -n eacl.datomic.performance-test \ No newline at end of file diff --git a/modules/eacl-datomic/test/eacl/datomic/schema_basis_test.clj b/modules/eacl-datomic/test/eacl/datomic/schema_basis_test.clj new file mode 100644 index 000000000..89ae87e2d --- /dev/null +++ b/modules/eacl-datomic/test/eacl/datomic/schema_basis_test.clj @@ -0,0 +1,203 @@ +(ns eacl.datomic.schema-basis-test + "Pins the Datomic behaviors the schema-digest cache scope (D8) relies on, + plus regressions for the cache-staleness bugs from the 2026-07-06 audit (§3). + A peer upgrade that changes any pinned behavior must fail loudly here — + every one was REPL-verified against peer 1.0.6733." + (:require [clojure.test :refer [deftest testing is]] + [datomic.api :as d] + [eacl.core :refer [spice-object]] + [eacl.datomic.datomic-helpers :refer [with-mem-conn]] + [eacl.datomic.impl :as impl :refer [Relation Permission Relationship]] + [eacl.datomic.impl.indexed :as idx] + [eacl.datomic.schema :as schema])) + +(def ^:private rel-tuple-attr :eacl.relation/resource-type+relation-name+subject-type) + +(defn- hist-rows + [db] + (->> (d/datoms (d/history db) :aevt rel-tuple-attr) + (map (juxt :v :added (comp d/tx->t :tx))) + (sort-by last) + (vec))) + +(deftest pinned-datomic-behaviors-test + (with-mem-conn [conn schema/v6-schema] + @(d/transact conn [(Relation :account :owner :user) + (Permission :account :admin {:relation :owner})]) + (let [db1 (d/db conn) + _ @(d/transact conn [[:db/add [:eacl/id "eacl.relation::account::owner::user"] + :eacl.relation/relation-name :holder]]) + db2 (d/db conn) + _ @(d/transact conn [[:db.fn/retractEntity [:eacl/id "eacl.relation::account::owner::user"]]]) + db3 (d/db conn)] + + (testing "a single-component edit rewrites the composite tuple in the SAME tx" + (let [t2 (d/basis-t db2) + rows (set (hist-rows db2))] + (is (contains? rows [[:account :holder :user] true t2])) + (is (contains? rows [[:account :owner :user] false t2])))) + + (testing "retractEntity retracts the tuple into history" + (is (contains? (set (hist-rows db3)) + [[:account :holder :user] false (d/basis-t db3)]))) + + (testing "(d/history (d/as-of db t)) is filtered to <= t" + (is (= [[[:account :owner :user] true (d/basis-t db1)]] + (hist-rows (d/as-of db3 (d/basis-t db1)))))) + + (testing "(d/basis-t (d/as-of db t)) returns the UNDERLYING basis — the digest filter must use d/as-of-t" + (is (= (d/basis-t db3) (d/basis-t (d/as-of db3 (d/basis-t db1))))) + (is (= (d/basis-t db1) (d/as-of-t (d/as-of db3 (d/basis-t db1)))))) + + (testing "d/history works on d/with db-afters and includes speculative datoms" + (let [dbw (:db-after (d/with db3 [(Relation :x :y :z)]))] + (is (some (fn [[v added _t]] (and (= v [:x :y :z]) added)) + (hist-rows dbw))))) + + (testing ".id returns the same database UUID on plain/as-of/with views" + (is (= (str (.id db3)) + (str (.id (d/as-of db3 (d/basis-t db1)))) + (str (.id (:db-after (d/with db3 []))))))) + + (testing "view classification predicates identify their views; with-dbs read as plain" + (is (false? (d/is-filtered db3))) + (is (false? (d/is-filtered (d/as-of db3 (d/basis-t db1))))) + (is (false? (d/is-filtered (d/since db3 (d/basis-t db1))))) + (is (true? (d/is-filtered (d/filter db3 (fn [_ _] true))))) + (is (true? (d/is-history (d/history db3)))) + (is (false? (d/is-history db3))) + (is (nil? (d/as-of-t (:db-after (d/with db3 []))))) + (is (nil? (d/since-t (:db-after (d/with db3 []))))) + (is (some? (d/since-t (d/since db3 (d/basis-t db1)))))) + + (testing "d/history on a d/filter db RESPECTS the filter" + ;; NOTE: an earlier audit pass concluded the opposite from a vacuous + ;; all-pass predicate (both behaviors coincide for it). Pinned with a + ;; hide-everything predicate instead. Filter views are still never + ;; cached: predicates are arbitrary functions (possibly impure or + ;; time-dependent), so their digests are not trustworthy as shared keys. + (let [hide-everything (d/filter db3 (fn [_ _] false))] + (is (zero? (count (hist-rows hide-everything)))))) + + (testing "d/history on a d/since db is since-filtered" + (is (< (count (hist-rows (d/since db3 (d/basis-t db1)))) + (count (hist-rows db3))))) + + (testing "Db equality is value- and content-based (safe to key the digest memo by db value)" + (is (.equals db3 (d/db conn))) + (let [wa (:db-after (d/with db3 [(Relation :wa :r :user)])) + wb (:db-after (d/with db3 [(Relation :wb :r :user)]))] + (is (false? (.equals wa wb)) + "different-content with-dbs at the same t must not be equal")))))) + +(deftest programmatic-schema-change-invalidation-test + ;; Audit §3: with (.id db)-keyed caches, a permission revoked via plain + ;; d/transact kept GRANTING ACCESS from cache. Invalidation is now derived + ;; from the schema history digest — no helper, no eviction, any peer. + (with-mem-conn [conn schema/v6-schema] + @(d/transact conn [(Relation :account :owner :user) + (Permission :account :admin {:relation :owner})]) + @(d/transact conn [{:db/id "u" :eacl/id "u"} {:db/id "a" :eacl/id "a"}]) + @(d/transact conn (impl/tx-relationship (d/db conn) + (Relationship (spice-object :user [:eacl/id "u"]) + :owner + (spice-object :account [:eacl/id "a"])))) + (idx/evict-permission-paths-cache!) + (let [db1 (d/db conn) + u (spice-object :user [:eacl/id "u"]) + a (spice-object :account [:eacl/id "a"])] + (is (true? (idx/can? db1 u :admin a))) + (is (= 1 (count (idx/get-permission-paths db1 :account :admin))) "cache populated") + + @(d/transact conn [[:db.fn/retractEntity + [:eacl/id "eacl:permission::account::admin::self::relation::owner"]]]) + (let [db2 (d/db conn)] + (testing "the revoked permission no longer grants access — no manual eviction" + (is (= 0 (count (idx/get-permission-paths db2 :account :admin)))) + (is (false? (idx/can? db2 u :admin a)))) + + (testing "as-of at the pre-change basis resolves the HISTORICAL paths, even after both were cached" + (is (= 1 (count (idx/get-permission-paths (d/as-of db2 (d/basis-t db1)) :account :admin)))) + (is (= 0 (count (idx/get-permission-paths db2 :account :admin))))))))) + +(deftest mutation-classes-change-digest-test + ;; Executable coverage invariant: every mutation class of both schema entity + ;; kinds must change the digest. + (with-mem-conn [conn schema/v6-schema] + @(d/transact conn [(Relation :account :owner :user) + (Permission :account :admin {:relation :owner})]) + (let [digests (atom [(idx/schema-basis-digest (d/db conn))]) + snap! (fn [] (swap! digests conj (idx/schema-basis-digest (d/db conn))))] + ;; add relation + @(d/transact conn [(Relation :account :viewer :user)]) + (snap!) + ;; edit relation component + @(d/transact conn [[:db/add [:eacl/id "eacl.relation::account::viewer::user"] + :eacl.relation/relation-name :viewer2]]) + (snap!) + ;; retract relation + @(d/transact conn [[:db.fn/retractEntity [:eacl/id "eacl.relation::account::viewer::user"]]]) + (snap!) + ;; add permission + @(d/transact conn [(Permission :account :view {:relation :owner})]) + (snap!) + ;; edit permission component + @(d/transact conn [[:db/add [:eacl/id "eacl:permission::account::view::self::relation::owner"] + :eacl.permission/target-name :viewer]]) + (snap!) + ;; retract permission + @(d/transact conn [[:db.fn/retractEntity [:eacl/id "eacl:permission::account::view::self::relation::owner"]]]) + (snap!) + (is (every? string? @digests)) + (is (= (count @digests) (count (distinct @digests))) + "each mutation class must produce a distinct digest")))) + +(deftest speculative-and-filtered-views-cannot-poison-cache-test + (with-mem-conn [conn schema/v6-schema] + @(d/transact conn [(Relation :account :owner :user) + (Permission :account :admin {:relation :owner})]) + (let [db (d/db conn) + perm-lookup-ref [:eacl/id "eacl:permission::account::admin::self::relation::owner"]] + + (testing "a d/with speculative schema edit computes its own paths and leaves the real db's entry intact" + (idx/evict-permission-paths-cache!) + (let [real-paths (idx/get-permission-paths db :account :admin) + dbw (:db-after (d/with db [[:db.fn/retractEntity perm-lookup-ref]])) + spec-paths (idx/get-permission-paths dbw :account :admin)] + (is (= 1 (count real-paths))) + (is (= 0 (count spec-paths))) + (is (= real-paths (idx/get-permission-paths db :account :admin)) + "the real db still resolves its own paths after the speculative computation"))) + + (testing "a d/filter db hiding the permission cannot publish empty paths under the plain db's key" + (idx/evict-permission-paths-cache!) + (let [perm-eid (d/entid db perm-lookup-ref) + filtered (d/filter db (fn [_db datom] (not= perm-eid (:e datom)))) + filt-paths (idx/get-permission-paths filtered :account :admin)] + (is (= 0 (count filt-paths)) "the filtered view itself must not see the permission") + (is (= 1 (count (idx/get-permission-paths db :account :admin))) + "the plain db, queried AFTER the filtered view, must still see it") + (is (nil? (idx/schema-basis-digest filtered)) + "filter views are unclassifiable and never share the cache")))))) + +(deftest unchanged-schema-cache-hit-test + (with-mem-conn [conn schema/v6-schema] + @(d/transact conn [(Relation :account :owner :user) + (Permission :account :admin {:relation :owner})]) + @(d/transact conn [{:eacl/id "u"} {:eacl/id "a"}]) + (idx/evict-permission-paths-cache!) + (let [calls (atom 0) + orig idx/calc-permission-paths] + (with-redefs [idx/calc-permission-paths (fn [& args] + (swap! calls inc) + (apply orig args))] + (idx/get-permission-paths (d/db conn) :account :admin) + (is (= 1 @calls)) + ;; unrelated (non-schema) relationship write between queries + @(d/transact conn (impl/tx-relationship (d/db conn) + (Relationship (spice-object :user [:eacl/id "u"]) + :owner + (spice-object :account [:eacl/id "a"])))) + (idx/get-permission-paths (d/db conn) :account :admin) + (is (= 1 @calls) + "unchanged schema across relationship writes must hit the cache"))))) diff --git a/modules/eacl-datomic/test/eacl/datomic/schema_test.clj b/modules/eacl-datomic/test/eacl/datomic/schema_test.clj index 05568f0d1..d8a7ce257 100644 --- a/modules/eacl-datomic/test/eacl/datomic/schema_test.clj +++ b/modules/eacl-datomic/test/eacl/datomic/schema_test.clj @@ -4,7 +4,8 @@ [eacl.datomic.datomic-helpers :refer [with-mem-conn]] [eacl.datomic.schema :as schema] [eacl.datomic.fixtures :as fixtures] - [eacl.datomic.impl :as impl])) + [eacl.datomic.impl :as impl] + [eacl.spicedb.parser])) (def example-schema-string "definition user {} @@ -170,6 +171,70 @@ (is (= 3 (count (:relations schema)))) (is (= 3 (count (:permissions schema))))))))) +(deftest write-schema-parse-failure-test + (testing "a malformed schema string throws a typed error and leaves the stored schema untouched" + (with-mem-conn [conn schema/v6-schema] + (schema/write-schema! conn example-schema-string) + (let [before (schema/read-schema (d/db conn))] + (try + ;; missing closing brace — pre-fix this silently retracted the ENTIRE schema + (schema/write-schema! conn "definition user {} + definition account { + relation owner: user + permission admin = owner") + (is false "should have thrown") + (catch clojure.lang.ExceptionInfo e + (is (= :eacl.schema/parse-error (:type (ex-data e)))))) + (is (= before (schema/read-schema (d/db conn))) + "schema must be unchanged after a failed write")))) + + (testing "a schema containing comments (e.g. pasted from the SpiceDB playground) writes cleanly" + (with-mem-conn [conn schema/v6-schema] + (is (schema/write-schema! conn "// users of the system + definition user {} + /* accounts own things */ + definition account { + relation owner: user // the owner + permission admin = owner + }")) + (is (= 1 (count (:relations (schema/read-schema (d/db conn))))))))) + +(deftest write-schema-empty-guard-test + (testing "zero-definition output cannot wipe a non-empty schema (parser-gap belt-and-braces)" + (with-mem-conn [conn schema/v6-schema] + (schema/write-schema! conn example-schema-string) + (with-redefs [eacl.spicedb.parser/->eacl-schema (fn [_] {:definitions [] :relations [] :permissions []})] + (try + (schema/write-schema! conn "anything") + (is false "should have thrown") + (catch clojure.lang.ExceptionInfo e + (is (= :eacl.schema/empty-schema-guard (:type (ex-data e)))))) + (testing "explicit opt-in allows the wipe when nothing would be orphaned" + (is (schema/write-schema! conn "anything" {:allow-empty-schema? true})) + (is (= {:relations [] :permissions []} (schema/read-schema (d/db conn))))))))) + +(deftest arrow-validation-order-independence-test + (let [schema-with-owner-types (fn [types] + (str "definition user { relation boss: user permission mgmt = boss } + definition group {} + definition account { relation owner: " types " + permission admin = owner->mgmt }"))] + (testing "arrow targets are validated against ALL subject types, regardless of declaration order" + ;; mgmt exists on user but not group: both orders must be rejected identically. + (doseq [types ["user | group" "group | user"]] + (with-mem-conn [conn schema/v6-schema] + (is (thrown-with-msg? clojure.lang.ExceptionInfo #"Invalid schema" + (schema/write-schema! conn (schema-with-owner-types types))) + (str "owner: " types " should be rejected — mgmt missing on group"))))) + + (testing "accepted when the target exists on every subject type" + (with-mem-conn [conn schema/v6-schema] + (is (schema/write-schema! conn + "definition user { relation boss: user permission mgmt = boss } + definition group { relation lead: user permission mgmt = lead } + definition account { relation owner: user | group + permission admin = owner->mgmt }")))))) + (deftest fixtures-schema-round-trip-test "Tests that fixtures.schema can be written and read back correctly. ADR 012 requirement: 'Rewrite the fixtures... to a new test/eacl/fixtures.schema file'" diff --git a/modules/eacl-datomic/test/eacl/spice_test.clj b/modules/eacl-datomic/test/eacl/spice_test.clj index 86e5c549e..fd1d2e5ec 100644 --- a/modules/eacl-datomic/test/eacl/spice_test.clj +++ b/modules/eacl-datomic/test/eacl/spice_test.clj @@ -10,9 +10,12 @@ [clojure.tools.logging :as log] [eacl.spicedb.consistency :as consistency :refer [fully-consistent]])) -(defn- read-relationships-data - [client query] - (:data (eacl/read-relationships client query))) +(defn- invalid-cursor-reason + [f] + (try (f) nil + (catch clojure.lang.ExceptionInfo e + (when (= :eacl/invalid-cursor (:type (ex-data e))) + (:reason (ex-data e)))))) (deftest opaque-cursor-token-test (testing "cursor->token round-trip preserves cursor" @@ -26,14 +29,206 @@ (testing "nil cursor produces nil token" (is (nil? (spiceomic/cursor->token nil)))) - (testing "nil or invalid input returns nil cursor" - (is (nil? (spiceomic/token->cursor nil))) - (is (nil? (spiceomic/token->cursor "garbage"))) - (is (nil? (spiceomic/token->cursor "eacl1_not-valid-base64!!!")))) + (testing "nil means first page" + (is (nil? (spiceomic/token->cursor nil)))) + + (testing "invalid input throws a typed error instead of silently restarting pagination (audit §7)" + (is (= :undecodable (invalid-cursor-reason #(spiceomic/token->cursor "garbage")))) + (is (= :undecodable (invalid-cursor-reason #(spiceomic/token->cursor "eacl1_not-valid-base64!!!"))))) + + (testing "tokens do not expire by default; expiry is enforced only when the client configures :cursor-ttl-seconds" + (let [cursor {:v 2 :e 123 :p {}} + expired-token (spiceomic/cursor->token cursor {:cursor-ttl-seconds -10})] + (testing "a stale token decodes fine under default (no-TTL) config" + (is (= cursor (spiceomic/token->cursor expired-token)))) + (testing "the same token throws {:reason :expired} when a TTL is configured" + (is (= :expired (invalid-cursor-reason #(spiceomic/token->cursor expired-token {:cursor-ttl-seconds 60}))))) + (testing "tokens without :t never expire, even with a TTL configured" + (is (= cursor (spiceomic/token->cursor (spiceomic/cursor->token cursor) {:cursor-ttl-seconds 60})))))) (testing "backward compat: raw cursor map passes through token->cursor" (let [cursor {:v 2 :e 12345 :p {0 67890}}] - (is (= cursor (spiceomic/token->cursor cursor)))))) + (is (= cursor (spiceomic/token->cursor cursor))))) + + (testing "v3 recursive cursor round-trips without coercion" + (let [cursor {:v 3 + :mode :recursive-forward + :max-depth 50 + :stack [{:kind :direct-stream + :node [:account :read] + :relation-eid 42 + :cursor 1001 + :depth 50}] + :best-depth {[:account :read] {1001 50}} + :emitted #{1001} + :last 1001} + token (spiceomic/cursor->token cursor)] + (is (= cursor (spiceomic/token->cursor token))) + (is (= cursor (spiceomic/default-internal-cursor->spice nil {} cursor))) + (is (= cursor (spiceomic/default-spice-cursor->internal nil {} cursor)))))) + +(deftest protocol-completeness-tests + ;; Audit §13: write-relationship!/delete-relationship! were declared on the + ;; protocol but unimplemented -> AbstractMethodError. + (with-mem-conn [conn schema/v6-schema] + (let [client (spiceomic/make-client conn {}) + u1 (spice-object :user "u1") + a1 (spice-object :account "a1")] + (eacl/write-schema! client "definition user {} + definition account { relation owner: user permission admin = owner }") + @(d/transact conn [{:eacl/id "u1"} {:eacl/id "a1"}]) + + (testing "write-relationship! (positional arity) creates and returns a token" + (let [{token :zed/token} (eacl/write-relationship! client :touch u1 :owner a1)] + (is (string? token)) + (is (true? (eacl/can? client u1 :admin a1))))) + + (testing "delete-relationship! (positional arity) removes" + (eacl/delete-relationship! client u1 :owner a1) + (is (false? (eacl/can? client u1 :admin a1)))) + + (testing "map arities work" + (eacl/write-relationship! client {:operation :touch :subject u1 :relation :owner :resource a1}) + (is (true? (eacl/can? client u1 :admin a1))) + (eacl/delete-relationship! client {:subject u1 :relation :owner :resource a1}) + (is (false? (eacl/can? client u1 :admin a1)))) + + (testing "unsupported consistency throws a typed error (not an assert)" + (try + (eacl/can? client u1 :admin a1 (consistency/fresh "tok")) + (is false "should have thrown") + (catch clojure.lang.ExceptionInfo e + (is (= :eacl/unsupported-consistency (:type (ex-data e))))))) + + (testing "expand-permission-tree throws a typed not-implemented error" + (try + (eacl/expand-permission-tree client {:resource a1 :permission :admin}) + (is false "should have thrown") + (catch clojure.lang.ExceptionInfo e + (is (= :eacl/not-implemented (:type (ex-data e)))))))))) + +(deftest cursor-schema-fingerprint-tests + (with-mem-conn [conn schema/v6-schema] + (let [client (spiceomic/make-client conn {}) + schema-v1 "definition user {} + definition account { relation owner: user relation viewer: user + permission admin = owner } + definition widget { relation owner: user relation editor: user + permission view = owner }" + ;; changes widget/view only — account/admin paths are untouched + schema-v2 "definition user {} + definition account { relation owner: user relation viewer: user + permission admin = owner } + definition widget { relation owner: user relation editor: user + permission view = owner + editor }" + ;; changes account/admin's own paths + schema-v3 "definition user {} + definition account { relation owner: user relation viewer: user + permission admin = owner + viewer } + definition widget { relation owner: user relation editor: user + permission view = owner + editor }"] + (eacl/write-schema! client schema-v1) + @(d/transact conn [{:eacl/id "u1"} {:eacl/id "a1"} {:eacl/id "a2"} {:eacl/id "a3"}]) + (eacl/create-relationships! client + [(->Relationship (->user "u1") :owner (->account "a1")) + (->Relationship (->user "u1") :owner (->account "a2")) + (->Relationship (->user "u1") :owner (->account "a3"))]) + (let [q {:subject (->user "u1") :permission :admin :resource/type :account :limit 2} + page1 (eacl/lookup-resources client q)] + (is (= ["a1" "a2"] (mapv :id (:data page1)))) + + (testing "unchanged schema resumes exactly, no duplicates or gaps" + (is (= ["a3"] (mapv :id (:data (eacl/lookup-resources client (assoc q :cursor (:cursor page1)))))))) + + (testing "an UNRELATED schema change does not invalidate the cursor" + (eacl/write-schema! client schema-v2) + (is (= ["a3"] (mapv :id (:data (eacl/lookup-resources client (assoc q :cursor (:cursor page1)))))))) + + (testing "a schema change to THIS query's paths throws :eacl/stale-cursor" + (eacl/write-schema! client schema-v3) + (try + (eacl/lookup-resources client (assoc q :cursor (:cursor page1))) + (is false "should have thrown") + (catch clojure.lang.ExceptionInfo e + (is (= :eacl/stale-cursor (:type (ex-data e))))))))))) + +(deftest strict-object-id-resolution-tests + (with-mem-conn [conn schema/v6-schema] + (let [client (spiceomic/make-client conn {})] + (eacl/write-schema! client "definition user {} + definition account { relation owner: user permission admin = owner }") + @(d/transact conn [{:eacl/id "alice"} {:eacl/id "bob"} {:eacl/id "acct-1"} {:eacl/id "acct-2"}]) + (eacl/create-relationships! client + [(->Relationship (spice-object :user "alice") :owner (spice-object :account "acct-1")) + (->Relationship (spice-object :user "bob") :owner (spice-object :account "acct-2"))]) + + (testing "read-relationships with a nonexistent subject returns [], not ALL relationships (audit §4)" + (is (= [] (vec (:data (eacl/read-relationships client {:resource/type :account + :subject/id "i-do-not-exist"}))))) + (is (= 1 (count (:data (eacl/read-relationships client {:resource/type :account + :subject/id "alice"})))))) + + (testing "lookups and counts return empty results for unknown objects (SpiceDB-consistent, D9)" + (is (= [] (:data (eacl/lookup-resources client {:subject (spice-object :user "ghost") + :permission :admin + :resource/type :account})))) + (is (= 0 (:count (eacl/count-resources client {:subject (spice-object :user "ghost") + :permission :admin + :resource/type :account})))) + (is (= [] (:data (eacl/lookup-subjects client {:resource (spice-object :account "no-such-acct") + :permission :admin + :subject/type :user})))) + (is (false? (eacl/can? client (spice-object :user "ghost") :admin (spice-object :account "acct-1"))))) + + (testing "writes to unknown objects throw :eacl/unknown-object naming the object (audit §11)" + (try + (eacl/create-relationships! client + [(->Relationship (spice-object :user "ghost-user") :owner (spice-object :account "acct-1"))]) + (is false "should have thrown") + (catch clojure.lang.ExceptionInfo e + (is (= :eacl/unknown-object (:type (ex-data e)))) + (is (= {:type :user :id "ghost-user"} (:object (ex-data e))))))))) + + (testing "make-client config validation (audit §5)" + (with-mem-conn [conn schema/v6-schema] + (let [setup (spiceomic/make-client conn {})] + (eacl/write-schema! setup "definition user {} + definition account { relation owner: user permission admin = owner }") + @(d/transact conn [{:eacl/id "u1"} {:eacl/id "a1"}]) + (eacl/create-relationships! setup + [(->Relationship (spice-object :user "u1") :owner (spice-object :account "a1"))]) + + (testing "the README-documented :entid->object-id key is honored" + (let [ext-client (spiceomic/make-client conn + {:entid->object-id (fn [db eid] (str "EXT-" (:eacl/id (d/entity db eid))))})] + (is (= ["EXT-a1"] + (mapv :id (:data (eacl/lookup-resources ext-client {:subject (spice-object :user "u1") + :permission :admin + :resource/type :account}))))))) + + (testing "the deprecated :entity->object-id alias still works" + (let [alias-client (spiceomic/make-client conn + {:entity->object-id (fn [ent] (str "ALIAS-" (:eacl/id ent)))})] + (is (= ["ALIAS-a1"] + (mapv :id (:data (eacl/lookup-resources alias-client {:subject (spice-object :user "u1") + :permission :admin + :resource/type :account}))))))) + + (testing "unknown option keys fail fast instead of silently falling back to defaults" + (try + (spiceomic/make-client conn {:entid->objectid (fn [_db eid] eid)}) ; misspelled + (is false "should have thrown") + (catch clojure.lang.ExceptionInfo e + (is (= :eacl/invalid-config (:type (ex-data e)))) + (is (= [:entid->objectid] (:unknown-keys (ex-data e))))))) + + (testing "supplying both the canonical key and the alias is rejected" + (try + (spiceomic/make-client conn {:entid->object-id (fn [_db eid] eid) + :entity->object-id (fn [ent] (:eacl/id ent))}) + (is false "should have thrown") + (catch clojure.lang.ExceptionInfo e + (is (= :eacl/invalid-config (:type (ex-data e))))))))))) (deftest spicedb-helper-tests (testing "spice-object takes [type id ?relation] and yields a SpiceObject with support for subject_relation" @@ -270,15 +465,15 @@ ; fixtures a bit confusing atm. (is (= #{(->Relationship super-user :super_admin ca-platform) (->Relationship (->user "super-user") :super_admin ca-platform)} - (set (read-relationships-data *client {:resource/type :platform}))))) + (set (:data (eacl/read-relationships *client {:resource/type :platform})))))) (testing "We can enumerate account owners:" (is (= #{(->Relationship my-user :owner my-account) (->Relationship joe's-user :owner acme-account) (->Relationship (->user "user-1") :owner (->account "account-1")) (->Relationship (->user "user-2") :owner (->account "account-2"))} - (set (read-relationships-data *client {:resource/type :account - :subject/type :user}))))) + (set (:data (eacl/read-relationships *client {:resource/type :account + :subject/type :user})))))) (testing "read-relationships supports various filters:" (testing "query platform->account" @@ -286,17 +481,17 @@ (->Relationship ca-platform :platform (->account "account-1")) (->Relationship ca-platform :platform (->account "account-2")) (->Relationship ca-platform :platform my-account)} - (set (read-relationships-data *client {:resource/type :account - :subject/type :platform - :resource/relation :platform}))))) + (set (:data (eacl/read-relationships *client {:resource/type :account + :subject/type :platform + :resource/relation :platform})))))) (testing "the same relationships show up if we omit :resource/relation" (is (= #{(->Relationship ca-platform :platform acme-account) (->Relationship ca-platform :platform (->account "account-1")) (->Relationship ca-platform :platform (->account "account-2")) (->Relationship ca-platform :platform my-account)} - (set (read-relationships-data *client {:resource/type :account - :subject/type :platform})))))) + (set (:data (eacl/read-relationships *client {:resource/type :account + :subject/type :platform}))))))) (testing "lookup-resources pagination tests" @@ -367,25 +562,6 @@ (is (string? (:e decoded)) "cursor :e should be coerced to external format"))))) - (testing "count-subjects is part of the public API with cursor tokens" - (let [{:keys [count cursor]} (eacl/count-subjects *client - {:resource (->server "123") - :permission :reboot - :subject/type :user - :limit 1})] - (testing "count-subjects returns a count" - (is (= 1 count))) - - (testing "cursor should be an opaque token" - (is (string? cursor)) - (is (.startsWith ^String cursor "eacl1_"))) - - (testing "cursor round-trips to v2 with string :e" - (let [decoded (spiceomic/token->cursor cursor)] - (is (= 2 (:v decoded))) - (is (string? (:e decoded)) - "cursor :e should be coerced to external format"))))) - (testing "spice-read-relationships results are constrained by filters for resource type & ID" (testing "transact the test entities we are about to use" @(d/transact conn (for [object [(->account "test-account") @@ -398,15 +574,12 @@ [(->Relationship (->account "test-account") :account (->vpc "my-vpc")) (->Relationship (->account "test-account") :account (->vpc "other-vpc")) (->Relationship (->account "other-account") :account (->vpc "other-vpc"))])) - (let [{:keys [data cursor]} - (eacl/read-relationships *client {:resource/type :vpc - :resource/id "my-vpc" - :resource/relation :account - :subject/type :account - :subject/id "test-account"})] - (is (= [(->Relationship (->account "test-account") :account (->vpc "my-vpc"))] - data)) - (is (string? cursor)))))) + (is (= [(->Relationship (->account "test-account") :account (->vpc "my-vpc"))] + (:data (eacl/read-relationships *client {:resource/type :vpc + :resource/id "my-vpc" + :resource/relation :account + :subject/type :account + :subject/id "test-account"}))))))) ; expand-permission-tree not impl. yet. ;; FIXME: These tests fail because expand-permission-tree is not implemented yet diff --git a/modules/eacl/src/eacl/cursor.cljc b/modules/eacl/src/eacl/cursor.cljc index 3d6566247..2448b0641 100644 --- a/modules/eacl/src/eacl/cursor.cljc +++ b/modules/eacl/src/eacl/cursor.cljc @@ -23,26 +23,59 @@ (.toString (.from js/Buffer value "base64") "utf8")))) (defn cursor->token - "Serializes an internal cursor map to an opaque string token with TTL." - [cursor & [{:keys [ttl-seconds] :or {ttl-seconds 300}}]] - (when cursor - (let [with-expiry (assoc cursor :t (+ (now-seconds) ttl-seconds))] - (str "eacl1_" (encode-string (pr-str with-expiry)))))) + "Serializes an internal cursor map to an opaque string token. + An expiry timestamp (:t, epoch seconds) is embedded only when the client is + configured with :cursor-ttl-seconds; by default tokens do not expire - + slow batch pagination must never silently restart (audit 7)." + ([cursor] (cursor->token cursor nil)) + ([cursor {:keys [cursor-ttl-seconds]}] + (when cursor + (let [cursor' (if cursor-ttl-seconds + (assoc cursor :t (+ (now-seconds) cursor-ttl-seconds)) + cursor)] + (str "eacl1_" (encode-string (pr-str cursor'))))))) (defn token->cursor - "Deserializes an opaque cursor token. Raw cursor maps are accepted for - backward compatibility." - [token-or-cursor] - (cond - (nil? token-or-cursor) nil - (map? token-or-cursor) token-or-cursor - (and (string? token-or-cursor) - (.startsWith ^String token-or-cursor "eacl1_")) - (try - (let [cursor (edn/read-string (decode-string (subs token-or-cursor 6))) - now (now-seconds)] - (when (> (:t cursor now) now) - (dissoc cursor :t))) - (catch #?(:clj Exception :cljs :default) _ - nil)) - :else nil)) + "Deserializes an opaque cursor token. + + Contract: + - nil means first page and returns nil; + - raw cursor maps pass through (backward compatibility); + - any other non-nil input that fails to decode throws + ex-info {:type :eacl/invalid-cursor :reason :undecodable}; + - a token carrying an expiry (:t) throws {:reason :expired} when expired and + the client is configured with :cursor-ttl-seconds. Tokens without :t never + expire. A bad cursor must fail loudly - decoding to nil silently restarted + pagination from the first page (audit 7)." + ([token-or-cursor] (token->cursor token-or-cursor nil)) + ([token-or-cursor {:keys [cursor-ttl-seconds]}] + (cond + (nil? token-or-cursor) nil + (map? token-or-cursor) token-or-cursor + + (and (string? token-or-cursor) + #?(:clj (.startsWith ^String token-or-cursor "eacl1_") + :cljs (.startsWith token-or-cursor "eacl1_"))) + (let [cursor (try + (edn/read-string (decode-string (subs token-or-cursor 6))) + (catch #?(:clj Exception :cljs :default) e + (throw (ex-info "Invalid cursor token: cannot be decoded." + {:type :eacl/invalid-cursor + :reason :undecodable} + e))))] + (when-not (map? cursor) + (throw (ex-info "Invalid cursor token: does not decode to a cursor map." + {:type :eacl/invalid-cursor + :reason :undecodable}))) + (if (and cursor-ttl-seconds (:t cursor) (> (now-seconds) (:t cursor))) + (throw (ex-info "Invalid cursor token: expired." + {:type :eacl/invalid-cursor + :reason :expired + :expired-at (:t cursor)})) + (dissoc cursor :t))) + + :else + (throw (ex-info "Invalid cursor token: unrecognized format." + {:type :eacl/invalid-cursor + :reason :undecodable + :token token-or-cursor}))))) diff --git a/modules/eacl/src/eacl/engine/indexed.cljc b/modules/eacl/src/eacl/engine/indexed.cljc index 878544378..acbad18a8 100644 --- a/modules/eacl/src/eacl/engine/indexed.cljc +++ b/modules/eacl/src/eacl/engine/indexed.cljc @@ -2,7 +2,9 @@ (:require [eacl.backend.spi :as spi] [eacl.core :refer [spice-object]] [eacl.lazy-merge-sort :as lazy-sort] - #?@(:clj [[clojure.tools.logging :as log]]))) + #?@(:clj [[clojure.tools.logging :as log]] + :cljs [[goog.crypt :as gcrypt]])) + #?(:cljs (:import [goog.crypt Sha256]))) (defn- warn [message data] @@ -20,6 +22,44 @@ [backend resource-type permission-name] [(spi/cache-stamp backend) resource-type permission-name]) +(defn fingerprint-digest + "128-bit hex digest of a value's printed representation. Used for cursor + fingerprints; compared only within a single runtime." + [x] + #?(:clj + (let [md (java.security.MessageDigest/getInstance "SHA-256")] + (.update md (.getBytes ^String (pr-str x) "UTF-8")) + (format "%032x" (java.math.BigInteger. 1 (java.util.Arrays/copyOf (.digest md) 16)))) + :cljs + (let [sha (Sha256.)] + (.update sha (gcrypt/stringToUtf8ByteArray (pr-str x))) + (gcrypt/byteArrayToHex (.slice (.digest sha) 0 16))))) + +(defn cursor-fingerprint + "Two-part cursor fingerprint: :s is the backend's cache stamp at mint time + (the schema-basis analog), :p digests this query's resolved paths." + [backend paths] + {:s (spi/cache-stamp backend) + :p (fingerprint-digest paths)}) + +(defn check-cursor-fingerprint! + "Guards cursor resumption against schema changes. An equal cache stamp means + the schema (as the backend tracks it) is unchanged, so the cursor resumes on + the fast path. A differing/absent stamp falls back to comparing this query's + resolved paths: equal means the change did not affect this query; different + throws :eacl/stale-cursor instead of silently mis-skipping via reordered :p + path indices. Cursors minted before fingerprints existed are accepted with + a warning." + [backend cursor paths] + (when (map? cursor) + (if-let [f (:f cursor)] + (let [current-s (spi/cache-stamp backend)] + (when-not (and (some? (:s f)) (= (:s f) current-s)) + (when-not (= (:p f) (fingerprint-digest paths)) + (throw (ex-info "Stale cursor: the permission paths for this query changed since the cursor was minted. Restart pagination." + {:type :eacl/stale-cursor}))))) + (warn "Cursor without a schema fingerprint accepted (minted before fingerprints existed)." {})))) + (defn evict-permission-paths-cache! [cache-atom] (reset! cache-atom {})) @@ -445,8 +485,10 @@ (defn lookup [backend direction get-permission-paths-fn query] - (let [{:keys [result-type-fn v1-cursor-key]} direction + (let [{:keys [result-type-fn v1-cursor-key perm-type-fn]} direction {:keys [limit cursor] :or {limit 1000}} query + paths (get-permission-paths-fn backend (perm-type-fn query) (:permission query)) + _ (check-cursor-fingerprint! backend cursor paths) {:keys [results path-results]} (lazy-merged-lookup backend direction get-permission-paths-fn query) limited-results (if (>= limit 0) (take limit results) @@ -455,11 +497,15 @@ items (doall (map #(spice-object result-type %) limited-results)) last-id (:id (last items))] {:data items - :cursor (build-v2-cursor cursor last-id path-results v1-cursor-key)})) + :cursor (assoc (build-v2-cursor cursor last-id path-results v1-cursor-key) + :f (cursor-fingerprint backend paths))})) (defn count-results [backend direction get-permission-paths-fn query default-v1-key] (let [{:keys [limit cursor] :or {limit -1}} query + perm-type-fn (:perm-type-fn direction) + paths (get-permission-paths-fn backend (perm-type-fn query) (:permission query)) + _ (check-cursor-fingerprint! backend cursor paths) {:keys [results path-results]} (lazy-merged-lookup backend direction get-permission-paths-fn query) limited-results (if (>= limit 0) (take limit results) @@ -468,4 +514,5 @@ last-id (last counted)] {:count (count counted) :limit limit - :cursor (build-v2-cursor cursor last-id path-results default-v1-key)})) + :cursor (assoc (build-v2-cursor cursor last-id path-results default-v1-key) + :f (cursor-fingerprint backend paths))})) diff --git a/modules/eacl/src/eacl/schema/model.cljc b/modules/eacl/src/eacl/schema/model.cljc index cdaa4a7bd..c6ca3c6b7 100644 --- a/modules/eacl/src/eacl/schema/model.cljc +++ b/modules/eacl/src/eacl/schema/model.cljc @@ -76,11 +76,17 @@ permission-names-by-type (into {} (for [[rt perms] permissions-by-type] [rt (set (map :eacl.permission/permission-name perms))])) - relation-subject-types (into {} - (for [rel relations] - [[(:eacl.relation/resource-type rel) - (:eacl.relation/relation-name rel)] - (:eacl.relation/subject-type rel)])) + ;; Subject types per relation as full SETS: multi-type relations + ;; (relation owner: user | group) expand to one entry per type, and + ;; validation must be independent of declaration order. + relation-subject-types (reduce (fn [acc rel] + (update acc + [(:eacl.relation/resource-type rel) + (:eacl.relation/relation-name rel)] + (fnil conj #{}) + (:eacl.relation/subject-type rel))) + {} + relations) errors (atom [])] (doseq [perm permissions] (let [res-type (:eacl.permission/resource-type perm) @@ -113,8 +119,8 @@ :message (str "Permission " (name res-type) "/" (name perm-name) " references non-existent relation: " (name source-rel))})) (when (contains? (get relation-names-by-type res-type) source-rel) - (let [target-res-type (get relation-subject-types [res-type source-rel])] - (when target-res-type + (doseq [target-res-type (get relation-subject-types [res-type source-rel])] + (do (if (= target-type :relation) (when-not (contains? (get relation-names-by-type target-res-type) target-name) (swap! errors conj diff --git a/modules/eacl/src/eacl/spicedb/parser.cljc b/modules/eacl/src/eacl/spicedb/parser.cljc index aba513c63..a4b285cda 100644 --- a/modules/eacl/src/eacl/spicedb/parser.cljc +++ b/modules/eacl/src/eacl/spicedb/parser.cljc @@ -8,6 +8,23 @@ [eacl.schema.model :as model])) ; primary-expr = identifier | <'('> permission-expr <')'> +;; Whitespace parser used by the comment-aware whitespace parser below. +(def ^:private whitespace + (insta/parser "whitespace = #'\\s+'")) + +;; SpiceDB schemas may contain // line comments and /* */ block comments +;; anywhere whitespace is legal. Modelled as auto-whitespace per the +;; instaparse whitespace-or-comments idiom. NOTE: the block-comment regex +;; uses [\s\S]*? rather than (?s).*? because JavaScript RegExp has no +;; inline dotall flag (CLJS compatibility). +(def ^:private whitespace-or-comments + (insta/parser + "ws-or-comments = ws | comments + comments = comment+ + comment = #'//[^\\n\\r]*' | #'/\\*[\\s\\S]*?\\*/' + ws = #'\\s+'" + :auto-whitespace whitespace)) + ;; Define the SpiceDB grammar with auto-whitespace ;; Full SpiceDB grammar - parses the complete official syntax. ;; EACL-specific restrictions are enforced during validation, not parsing. @@ -59,7 +76,7 @@ (* Identifiers - must not match keywords *) identifier = !('nil' | 'self' | 'definition' | 'relation' | 'permission' | 'with' | 'any' | 'all') #'[a-zA-Z_][a-zA-Z0-9_]*'" - :auto-whitespace :standard)) + :auto-whitespace whitespace-or-comments)) ;; Example SpiceDB schema (def example-schema @@ -137,7 +154,15 @@ (let [rel-name (extract-identifier (second rel-name-node)) type-refs (extract-relation-type-expr type-expr-node)] [rel-name type-refs]))) - (into {})) + (reduce (fn [acc [rel-name type-refs]] + (if (contains? acc rel-name) + (throw (ex-info (str "Duplicate relation declaration: '" rel-name "'." + " Declare multiple subject types once with `|`," + " e.g. `relation " rel-name ": a | b`.") + {:type :eacl.schema/duplicate-relation + :relation rel-name})) + (assoc acc rel-name type-refs))) + {})) {})) (defn extract-permissions @@ -159,17 +184,37 @@ (->> parse-tree (filter #(and (vector? %) (= :definition (first %)))) (map (fn [[_ type-path-node definition-body]] - (let [type-path (extract-type-path type-path-node)] + (let [type-path (extract-type-path type-path-node) + relations (extract-relations definition-body) + permissions (extract-permissions definition-body) + collisions (filter (set (keys relations)) (map :name permissions))] + (when (seq collisions) + (throw (ex-info (str "Permission and relation share a name on definition '" type-path + "': " (pr-str (vec collisions))) + {:type :eacl.schema/name-collision + :definition type-path + :names (vec collisions)}))) [type-path - {:relations (extract-relations definition-body) - :permissions (extract-permissions definition-body)}]))) - (into {}))) + {:relations relations + :permissions permissions}]))) + (reduce (fn [acc [type-path spec]] + (if (contains? acc type-path) + (throw (ex-info (str "Duplicate definition: '" type-path "'." + " Each type may be defined once; merge the blocks.") + {:type :eacl.schema/duplicate-definition + :definition type-path})) + (assoc acc type-path spec))) + {}))) (defn transform-schema - "Transform parse tree to intermediate representation." + "Transform parse tree to intermediate representation. + Throws on unexpected input; a failed parse must never coerce to an empty schema." [parse-tree] - (when (and (vector? parse-tree) (= :schema (first parse-tree))) - {:definitions (extract-definitions (rest parse-tree))})) + (if (and (vector? parse-tree) (= :schema (first parse-tree))) + {:definitions (extract-definitions (rest parse-tree))} + (throw (ex-info "Unexpected schema parse tree; refusing to interpret as an empty schema." + {:type :eacl.schema/parse-error + :parse-tree parse-tree})))) ;; Helper to parse expressions (defn parse-permission-expression [expr-str] @@ -321,12 +366,18 @@ :operator "-" :message "Unsupported operator: Exclusion (-). EACL only supports Union (+) at this time."})) - ;; Check for multi-level arrows + ;; Check for multi-level arrows and parenthesized arrow bases/targets :simple-arrow-expr - (when (> (count (filter #(and (vector? %) (= :base-expr (first %))) (rest node))) 2) - (swap! issues conj - {:type :multi-level-arrow - :message "Unsupported feature: Multi-level arrows (e.g., a->b->c). EACL only supports single-level arrows like rel->perm."})) + (let [base-exprs (filter #(and (vector? %) (= :base-expr (first %))) (rest node))] + (when (> (count base-exprs) 2) + (swap! issues conj + {:type :multi-level-arrow + :message "Unsupported feature: Multi-level arrows (e.g., a->b->c). EACL only supports single-level arrows like rel->perm."})) + (when (and (> (count base-exprs) 1) + (some #(and (vector? (second %)) (= :paren-expr (first (second %)))) base-exprs)) + (swap! issues conj + {:type :paren-arrow + :message "Unsupported feature: Parenthesized expressions as arrow bases or targets (e.g., (a + b)->c). Arrows take a single relation base."}))) ;; Check for .all() function (only .any() is implicitly supported via arrow) :arrow-func-expr @@ -453,6 +504,8 @@ ;; Converts new grammar parse tree to component list for EACL ;; ============================================================================ +(declare transform-union-expr) + (defn- extract-base-expr-identifier "Extract identifier string from a base-expr node." [node] @@ -461,6 +514,14 @@ (when (and (vector? child) (= :identifier (first child))) (second child))))) +(defn- base-expr-paren-child + "Returns the inner permission-expr node when a base-expr wraps a paren-expr, else nil." + [node] + (when (and (vector? node) (= :base-expr (first node))) + (let [child (second node)] + (when (and (vector? child) (= :paren-expr (first child))) + (second child))))) + (defn- transform-arrow-expr "Transform an arrow expression to component maps. Returns vector of {:type :identifier/:arrow, ...} maps." @@ -476,15 +537,23 @@ ;; .any() is equivalent to arrow, .all() should have been rejected by validation [{:type :arrow :base {:type :identifier :name base-id} :path [target-id]}]) - ;; Simple arrow expression: rel->perm or rel->perm->perm2 + ;; Simple arrow expression: identifier, (paren union), or rel->perm chains (and (vector? node) (= :simple-arrow-expr (first node))) - (let [base-exprs (filter #(and (vector? %) (= :base-expr (first %))) (rest node)) - ids (map extract-base-expr-identifier base-exprs)] - (if (= 1 (count ids)) - ;; Single identifier - direct permission/relation reference - [{:type :identifier :name (first ids)}] - ;; Arrow expression - [{:type :arrow :base {:type :identifier :name (first ids)} :path (vec (rest ids))}])) + (let [base-exprs (filter #(and (vector? %) (= :base-expr (first %))) (rest node))] + (if (= 1 (count base-exprs)) + (let [base-expr (first base-exprs)] + (if-let [inner-permission-expr (base-expr-paren-child base-expr)] + ;; Parenthesized union operand: flatten to its components (EACL is union-only). + (vec (transform-union-expr (second inner-permission-expr))) + ;; Single identifier - direct permission/relation reference + [{:type :identifier :name (extract-base-expr-identifier base-expr)}])) + ;; Arrow chain: every element must be a plain identifier. + (let [ids (map extract-base-expr-identifier base-exprs)] + (when (some nil? ids) + (throw (ex-info "Parenthesized expressions are not supported as arrow bases or targets." + {:type :eacl.schema/paren-arrow + :node node}))) + [{:type :arrow :base {:type :identifier :name (first ids)} :path (vec (rest ids))}]))) ;; Wrapped arrow expr (and (vector? node) (= :arrow-expr (first node))) @@ -519,23 +588,18 @@ ;; ============================================================================ (defn- collect-schema-info - "Build lookup tables from transformed schema for arrow resolution." + "Build lookup tables from transformed schema for arrow resolution. + Relation subject types are kept as full sets so arrow resolution and + validation can never depend on declaration order." [definitions] (reduce-kv (fn [acc res-type {:keys [relations permissions]}] - (let [;; Get simple type names (first type ref for each relation) - relation-names (set (keys relations)) - ;; Map relation name to target type (first type in list) - relation-types (into {} - (for [[rel-name type-refs] relations - :let [first-ref (first type-refs)] - :when first-ref] - [rel-name (:type first-ref)]))] - (assoc acc res-type - {:relations relation-names - :relation-types relation-types - :relation-all-types relations - :permissions (set (map :name permissions))}))) + (assoc acc res-type + {:relations (set (keys relations)) + :relation-subject-types (into {} + (for [[rel-name type-refs] relations] + [rel-name (set (keep :type type-refs))])) + :permissions (set (map :name permissions))})) {} definitions)) @@ -560,14 +624,37 @@ path-elements (:path component) path (first path-elements) info (get schema-info resource-type) - target-type (get-in info [:relation-types base-name])] - (if-not target-type + subject-types (get-in info [:relation-subject-types base-name])] + (if (empty? subject-types) (throw (ex-info (str "Unknown relation for arrow base: " base-name " on " resource-type) {:component component :resource-type resource-type})) - (let [target-info (get schema-info target-type) - target-is-relation (contains? (:relations target-info) path)] - {:arrow (keyword base-name) - (if target-is-relation :relation :permission) (keyword path)}))) + ;; Resolve the target kind against ALL subject types of the base relation, + ;; never just the first/last declared one - otherwise resolution and + ;; validation become declaration-order-dependent. + (let [kinds (set (map (fn [subject-type] + (let [target-info (get schema-info subject-type)] + (cond + (contains? (:relations target-info) path) :relation + (contains? (:permissions target-info) path) :permission + :else :missing))) + subject-types)) + present (disj kinds :missing)] + (cond + (= present #{:relation :permission}) + (throw (ex-info (str "Arrow target '" path "' resolves to a relation on some subject types of '" + base-name "' and a permission on others: " (pr-str subject-types)) + {:type :eacl.schema/mixed-arrow-target + :component component + :resource-type resource-type + :subject-types subject-types})) + + (= present #{:relation}) + {:arrow (keyword base-name) :relation (keyword path)} + + ;; :permission on all types that have it, or missing everywhere - + ;; validate-schema-references produces the per-type missing errors. + :else + {:arrow (keyword base-name) :permission (keyword path)})))) (throw (ex-info "Unsupported component type" {:component component})))) @@ -583,15 +670,25 @@ 2. Validate EACL restrictions (throws on unsupported features) 3. Convert to EACL Relations and Permissions - Returns {:relations [...] :permissions [...]}" + Returns {:definitions [...] :relations [...] :permissions [...]}. + Throws :eacl.schema/parse-error on instaparse failure input - a failed parse + must never become an empty schema (write-schema! diffs against the existing + schema, so an empty result would retract everything)." [parse-tree] + (when (insta/failure? parse-tree) + (let [failure (insta/get-failure parse-tree)] + (throw (ex-info (str "Schema parse error: " (pr-str failure)) + {:type :eacl.schema/parse-error + :failure failure})))) (let [transformed (transform-schema parse-tree)] ;; Validate EACL restrictions (parsing allows full SpiceDB, validation enforces limits) (validate-eacl-restrictions parse-tree transformed) (let [definitions (:definitions transformed) schema-info (collect-schema-info definitions)] - {:relations + {:definitions (vec (keys definitions)) + + :relations (vec ;; Expand multi-type relations into multiple Relation entities (for [[res-type {:keys [relations]}] definitions From 6f8611a3596e2736869d477c08201dc4133e5b0e Mon Sep 17 00:00:00 2001 From: Petrus Theron Date: Tue, 14 Jul 2026 18:11:43 +0200 Subject: [PATCH 05/13] =?UTF-8?q?fix=20#74:=20only=20write-schema!=20busts?= =?UTF-8?q?=20the=20path=20cache=20=E2=80=94=20revert=20derived=20digest?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The schema-history digest (D8) recomputed per fresh db basis, i.e. after every d/transact: unrelated relationship writes paid an O(schema-history) scan for schema-change detection. That does not scale under write load. Replace derivation with a signaled stamp: write-schema! asserts a fresh :eacl/schema-version squuid on the schema singleton in the same transaction as any definition change, and the path/plan caches key on [(.id db) version resource-type permission-name]. Reading the stamp is one AVET lookup — no history scans — and unrelated transactions leave every cache key untouched. Retained from the audit fixes: - as-of correctness (§3): as-of views read their era's version datom, so historic bases get their own cache slots — no cross-base slot sharing. - Cross-peer invalidation: the stamp lives in the db, so a write-schema! on any peer invalidates all peers (works without the local eviction, which remains as hygiene + manual recovery hatch). - Positive view classification: filter/since/history views bypass the caches entirely; any stamp-read failure degrades to a miss, never a stale hit. - Counter-elision safety: a squuid (not a counter) cannot be re-asserted to an unchanged value by a concurrent writer. - Cursor fingerprints keep the {:s :p} shape (:s = version string) and survive restarts since the stamp is stored. Consciously accepted (by design, per #74): programmatic relation/permission datom edits (raw d/transact, d/with, excision) no longer invalidate caches and may serve stale paths until the next write-schema! or manual evict-permission-paths-cache!. Users must not manage EACL schema outside the API. write-schema! installs the :eacl/schema-version attribute just-in-time on databases created before it existed, and skips the version bump when the definition delta is empty (no-op rewrites keep caches and cursors hot). Tests: schema_basis_test.clj rewritten to pin the new contract (unrelated transacts hit the cache; invalidation works with eviction disabled; as-of resolves historical paths; raw-edit staleness documented as intended). Cold clj -X:test: 56 tests, 854 assertions, 0 failures. Co-Authored-By: Claude Fable 5 --- .../changes/fix-audit-root-causes/design.md | 2 + src/eacl/datomic/impl/indexed.clj | 137 ++++----- src/eacl/datomic/schema.clj | 34 ++- test/eacl/datomic/schema_basis_test.clj | 286 ++++++++---------- 4 files changed, 222 insertions(+), 237 deletions(-) diff --git a/openspec/changes/fix-audit-root-causes/design.md b/openspec/changes/fix-audit-root-causes/design.md index 6dc4ec052..c7a5e45f3 100644 --- a/openspec/changes/fix-audit-root-causes/design.md +++ b/openspec/changes/fix-audit-root-causes/design.md @@ -77,6 +77,8 @@ The `(= attr-eid (:a d))` guard is mandatory — `seek-datoms` iterates past the ### D8. Cache keys carry a schema-history digest; invalidation is derived, not signaled +> **SUPERSEDED (2026-07-14, issue #74).** The derived digest was reverted: computing it requires a schema-history scan per fresh db basis, i.e. after **every** `d/transact` — unrelated relationship writes paid for schema-change detection, which does not scale under write load. The shipped design is a signaled stamp: `write-schema!` asserts a fresh `:eacl/schema-version` **squuid** on the schema singleton in the same transaction as any definition change, and both caches key on `[(.id db) version …]` (one AVET lookup, no scans, untouched by unrelated transactions). Of the six loopholes below that motivated the digest: the squuid (not a counter) closes the counter-elision race; nothing memoizes eids, so there is no anchor-eid hazard; no `t` arithmetic remains (as-of views read their era's version datom natively); positive view classification and failure-degrades-to-miss are retained verbatim. The one consciously **accepted** loophole is the unenforceable-contract one: programmatic relation/permission datom edits (raw `d/transact`, `d/with`, excision) no longer invalidate anything and may be served stale paths until the next `write-schema!` or manual `evict-permission-paths-cache!` — per issue #74, users must not manage EACL schema outside the API. Cursor fingerprints keep the same two-part `{:s :p}` shape with `:s` = the version string. The digest text below is retained as the record of why the derived approach was tried. + Both caches key on `[(.id db) (schema-basis db) …]` where `(schema-basis db)` is a 128-bit digest (SHA-256 truncated to 128 bits — collision resistance, not security; SHA-256 rather than MD5 so FIPS-mode JVMs don't silently lose caching to the failure fallback) folded, in index order, over the **history datoms** of the two unique composite tuple attributes — `:eacl.relation/resource-type+relation-name+subject-type` and `:eacl.permission/resource-type+source-relation-name+target-type+target-name+permission-name` — each datom contributing `[e v t added?]`, filtered to `t ≤ (or (d/as-of-t db) (d/basis-t db))`. An earlier draft of this decision used an anchor entity (`[:eacl/id "schema-string"]` max-`:tx`) plus a `:eacl/schema-version` counter and touch helpers for programmatic writers. An adversarial review found six loopholes in that shape; each clause of the digest design closes one: diff --git a/src/eacl/datomic/impl/indexed.clj b/src/eacl/datomic/impl/indexed.clj index 979b2c96c..371d865c4 100644 --- a/src/eacl/datomic/impl/indexed.clj +++ b/src/eacl/datomic/impl/indexed.clj @@ -117,42 +117,58 @@ (defn evict-permission-paths-cache! "Manual override that clears both the permission-path and query-plan caches. - No longer required for correctness (cache keys carry a schema-history digest), - but retained for immediate local effect and belt-and-braces." + write-schema! calls it for immediate local hygiene; cross-peer and as-of + correctness rely on the :eacl/schema-version cache key, not on this. It is + also the recovery hatch after unsupported programmatic schema edits." [] (reset! permission-paths-cache (cache/lru-cache-factory {} :threshold 1000)) (reset! recursive-query-plan-cache (cache/lru-cache-factory {} :threshold 256))) -;; --- Schema-history digest cache scope ------------------------------------- +;; --- Schema-version cache scope (issue #74) --------------------------------- ;; -;; Coverage invariant: every attribute that permission-path / query-plan -;; computation reads MUST be a component of one of the composite tuples -;; digested below. Datomic rewrites a composite tuple datom in the same -;; transaction as ANY component change, and retractEntity retracts it, so the -;; tuple histories are a complete record of path-relevant schema mutations. -;; If you add a new path-relevant attribute outside these tuples, add its -;; history to the digest or caches will serve stale paths. - -(def ^:private schema-digest-attrs - [:eacl.relation/resource-type+relation-name+subject-type - :eacl.permission/resource-type+source-relation-name+target-type+target-name+permission-name]) - -(defonce ^:private schema-scope-memo - ;; Keyed by the db value itself: Datomic Db equality is value- and - ;; content-based (pinned by tests), so this can only unify db values whose - ;; visible histories — and therefore digests — are identical. Weak keys - ;; release with the db value. Sentinel (uncached) scopes are never stored. - (java.util.Collections/synchronizedMap (java.util.WeakHashMap.))) +;; The path/plan caches are invalidated ONLY by eacl.datomic.schema/write-schema!, +;; which asserts a fresh :eacl/schema-version squuid on the schema singleton in +;; the same transaction as any definition change. Reading the stamp is a single +;; AVET lookup — O(log N), no history scans — and unrelated d/transact calls +;; leave it (and therefore every cache key) untouched, so relationship write +;; load can never evict or recompute paths. (The previous design derived a +;; digest from schema history per db basis, i.e. recomputed after every +;; transact — issue #74.) +;; +;; Contract: permission schema mutations MUST go through write-schema!. +;; Programmatic edits of relation/permission datoms (raw d/transact, d/with, +;; excision) do not bump the version, so caches and cursors may serve paths +;; computed from the pre-edit schema until the next write-schema! or a manual +;; evict-permission-paths-cache!. That trade-off is by design. +;; +;; The stamp lives in the database, not in peer memory, so: +;; - write-schema! on any peer invalidates every peer (the stored value changes); +;; - d/as-of views read the version that was current at that basis, giving +;; historic views their own cache slots (audit §3 fix, preserved); +;; - a squuid can never be re-asserted to an unchanged value by a concurrent +;; writer (no counter-elision race); +;; - cursor fingerprints survive process restarts. + +(def schema-version-attr + "Installed by eacl.datomic.schema/v7-schema; asserted by write-schema!." + :eacl/schema-version) + +(defn schema-version + "The schema-version squuid asserted by the most recent write-schema! visible + in this db value, or nil for databases that predate versioned schema writes. + A single AVET lookup on a one-datom attribute." + [db] + (when (d/entid db schema-version-attr) + (:v (first (d/datoms db :avet schema-version-attr))))) (def ^:private uncached-scope [::uncached]) (defn- classified-view - "Positively classifies a db value: :plain, :as-of, or nil for anything the - digest must not be shared for. d/filter views are excluded because their - predicates are arbitrary functions (possibly impure or time-dependent), so - a digest of their filtered history is not trustworthy as a shared cache key; - d/since views hide old schema and are pointless to cache; history views are - not queryable schema states." + "Positively classifies a db value: :plain, :as-of, or nil for any view the + version stamp cannot be trusted on. d/filter views are excluded because their + predicates are arbitrary functions that may hide definition datoms without + hiding the version datom; d/since views hide old schema and are pointless to + cache; history views are not queryable schema states." [db] (cond (d/is-history db) nil @@ -161,48 +177,26 @@ (some? (d/as-of-t db)) :as-of :else :plain)) -(defn- schema-history-digest - "128-bit hex digest (SHA-256 truncated; FIPS-safe) folded in index order over - the history datoms of the schema composite tuple attrs, filtered to the - db's visible basis. Content-derived: any schema mutation — write-schema!, - programmatic transaction, retraction, or excision — changes it, on every peer, - with no writer-side signal." - [db] - (let [md (java.security.MessageDigest/getInstance "SHA-256") - ;; d/basis-t of an as-of view returns the UNDERLYING basis (REPL-verified), - ;; so the visibility filter must prefer d/as-of-t. - limit-t (or (d/as-of-t db) (d/basis-t db)) - hist (d/history db)] - (doseq [attr schema-digest-attrs - datom (d/datoms hist :aevt attr) - :let [t (d/tx->t (:tx datom))] - :when (<= t limit-t)] - (.update md (.getBytes (pr-str [(:e datom) (:v datom) t (:added datom)]) "UTF-8"))) - (format "%032x" (java.math.BigInteger. 1 (java.util.Arrays/copyOf (.digest md) 16))))) - (defn- schema-cache-scope - "Returns [database-id schema-history-digest] for positively classified + "Returns [database-id schema-version-string] for positively classified plain/as-of db values, or a sentinel scope for anything else (filter, since, history, unrecognized views) and for ANY failure. Sentinel scopes bypass the caches entirely: every failure mode degrades to recomputation from the queried db value — never to serving a stale entry." [db] - (or (.get ^java.util.Map schema-scope-memo db) - (let [scope (try - (when (classified-view db) - [(str (.id db)) (schema-history-digest db)]) - (catch Throwable _ nil))] - (if scope - (do (.put ^java.util.Map schema-scope-memo db scope) - scope) - uncached-scope)))) + (or (try + (when (classified-view db) + [(str (.id db)) (some-> (schema-version db) str)]) + (catch Throwable _ nil)) + uncached-scope)) (defn- uncached-scope? [scope] (identical? uncached-scope scope)) -(defn schema-basis-digest - "The schema-history digest for this db value, or nil when the view cannot be - cached (see schema-cache-scope). Used for cursor fingerprints." +(defn schema-version-stamp + "String form of the schema version for this db value, or nil when no version + has been written yet or the view cannot be classified (see schema-cache-scope). + Used for cursor fingerprints; nil forces the :p paths-digest comparison." [db] (let [scope (schema-cache-scope db)] (when-not (uncached-scope? scope) @@ -216,24 +210,27 @@ (format "%032x" (java.math.BigInteger. 1 (java.util.Arrays/copyOf (.digest md) 16))))) (defn- cursor-fingerprint - "Two-part cursor fingerprint: :s is the schema-history digest at mint time - (nil on unclassifiable views), :p digests this query's resolved paths/plan." + "Two-part cursor fingerprint: :s is the schema-version stamp at mint time + (nil on unclassifiable views or pre-version databases), :p digests this + query's resolved paths/plan." [db paths-or-plan] - {:s (schema-basis-digest db) + {:s (schema-version-stamp db) :p (fingerprint-digest paths-or-plan)}) (defn- check-cursor-fingerprint! - "Guards cursor resumption against schema changes. Equal schema digests prove - identical schema history, so the cursor resumes on the fast path. A differing - (or unavailable) schema digest falls back to comparing this query's resolved - paths/plan: equal means the schema change did not affect this query; different - throws :eacl/stale-cursor instead of silently mis-skipping via reordered :p - path indices or replaying a stale v3 :stack. Cursors minted before - fingerprints existed are accepted with a warning." + "Guards cursor resumption against schema changes. An equal schema-version + stamp means no write-schema! ran between mint and resume (programmatic datom + edits bypass the stamp — see the schema-version contract above), so the + cursor resumes on the fast path. A differing (or unavailable) stamp falls + back to comparing this query's resolved paths/plan: equal means the schema + change did not affect this query; different throws :eacl/stale-cursor instead + of silently mis-skipping via reordered :p path indices or replaying a stale + v3 :stack. Cursors minted before fingerprints existed are accepted with a + warning." [db cursor paths-or-plan] (when (map? cursor) (if-let [f (:f cursor)] - (let [current-s (schema-basis-digest db)] + (let [current-s (schema-version-stamp db)] (when-not (and (:s f) current-s (= (:s f) current-s)) (when-not (= (:p f) (fingerprint-digest paths-or-plan)) (throw (ex-info "Stale cursor: the permission paths for this query changed since the cursor was minted. Restart pagination." diff --git a/src/eacl/datomic/schema.clj b/src/eacl/datomic/schema.clj index 8745173dd..581e16959 100644 --- a/src/eacl/datomic/schema.clj +++ b/src/eacl/datomic/schema.clj @@ -36,6 +36,19 @@ ;(def Permission ; [:or DirectPermission ArrowPermission]) +(def schema-version-attr-definition + "Cache-invalidation stamp. write-schema! asserts a fresh squuid here in the + same transaction as any definition change; EACL's permission-path caches and + cursor fingerprints key on it, so ONLY write-schema! invalidates them (#74). + A squuid (not a counter) so two concurrent writers can never assert the same + value and elide each other's invalidation. Do not edit EACL definitions + outside write-schema! — the stamp will not change and caches will be stale." + {:db/ident :eacl/schema-version + :db/doc "Squuid bumped by write-schema! whenever definitions change. Path caches and cursor fingerprints key on it." + :db/valueType :db.type/uuid + :db/cardinality :db.cardinality/one + :db/index true}) + (def v7-schema [; :eacl/id is now optional. {:db/ident :eacl/id ; todo: figure out how to support :id, :object/id or :spice/id of different types. @@ -49,6 +62,8 @@ :db/valueType :db.type/string :db/cardinality :db.cardinality/one} + schema-version-attr-definition + ;; Relations {:db/ident :eacl.relation/resource-type :db/doc "EACL Relation: Resource Type" @@ -386,6 +401,9 @@ ([conn schema-string] (write-schema! conn schema-string {})) ([conn schema-string {:keys [allow-empty-schema?]}] + ;; Upgrade path: databases installed before :eacl/schema-version existed. + (when-not (d/entid (d/db conn) :eacl/schema-version) + @(d/transact conn [schema-version-attr-definition])) (let [new-schema-map (parser/->eacl-schema (parser/parse-schema schema-string)) ;; Validate schema references before proceeding (ADR 012 requirement) _ (validate-schema-references new-schema-map) @@ -414,7 +432,11 @@ {:relation rel :count cnt}))))) ;; Transact changes - (let [tx-data (concat + (let [schema-changed? (boolean (or (seq (:additions relations)) + (seq relation-retractions) + (seq (:additions permissions)) + (seq permission-retractions))) + tx-data (concat ;; Additions (:additions relations) (:additions permissions) @@ -423,9 +445,13 @@ [:db.fn/retractEntity [:eacl/id (:eacl/id rel)]]) (for [perm permission-retractions] [:db.fn/retractEntity [:eacl/id (:eacl/id perm)]]) - ;; Store schema string - [{:eacl/id "schema-string" - :eacl/schema-string schema-string}])] + ;; Store schema string + bump the version stamp when + ;; definitions changed. The stamp is what invalidates the + ;; path caches and cursor fingerprints — on every peer, + ;; and correctly for d/as-of views (issue #74). + [(cond-> {:eacl/id "schema-string" + :eacl/schema-string schema-string} + schema-changed? (assoc :eacl/schema-version (d/squuid)))])] @(d/transact conn tx-data) (impl.indexed/evict-permission-paths-cache!) deltas)))) diff --git a/test/eacl/datomic/schema_basis_test.clj b/test/eacl/datomic/schema_basis_test.clj index 89ae87e2d..89281815d 100644 --- a/test/eacl/datomic/schema_basis_test.clj +++ b/test/eacl/datomic/schema_basis_test.clj @@ -1,8 +1,13 @@ (ns eacl.datomic.schema-basis-test - "Pins the Datomic behaviors the schema-digest cache scope (D8) relies on, - plus regressions for the cache-staleness bugs from the 2026-07-06 audit (§3). - A peer upgrade that changes any pinned behavior must fail loudly here — - every one was REPL-verified against peer 1.0.6733." + "Pins the write-schema!-driven cache-invalidation contract (issue #74) and + the Datomic view-classification facts the cache scope relies on, plus the + audit §3 regression (no cache-slot sharing across db bases). + + The contract: ONLY eacl.datomic.schema/write-schema! invalidates the + permission-path caches — it bumps :eacl/schema-version in the same + transaction as any definition change. Unrelated d/transact calls must leave + every cache key untouched. Programmatic edits of relation/permission datoms + bypass the stamp and are explicitly unsupported (issue #74)." (:require [clojure.test :refer [deftest testing is]] [datomic.api :as d] [eacl.core :refer [spice-object]] @@ -11,92 +16,52 @@ [eacl.datomic.impl.indexed :as idx] [eacl.datomic.schema :as schema])) -(def ^:private rel-tuple-attr :eacl.relation/resource-type+relation-name+subject-type) +(def ^:private schema-v1 + "definition user {} + definition account { relation owner: user + permission admin = owner }") -(defn- hist-rows - [db] - (->> (d/datoms (d/history db) :aevt rel-tuple-attr) - (map (juxt :v :added (comp d/tx->t :tx))) - (sort-by last) - (vec))) +(def ^:private schema-v2 + "definition user {} + definition account { relation owner: user + relation viewer: user + permission admin = owner + viewer }") (deftest pinned-datomic-behaviors-test (with-mem-conn [conn schema/v6-schema] - @(d/transact conn [(Relation :account :owner :user) - (Permission :account :admin {:relation :owner})]) + (schema/write-schema! conn schema-v1) (let [db1 (d/db conn) - _ @(d/transact conn [[:db/add [:eacl/id "eacl.relation::account::owner::user"] - :eacl.relation/relation-name :holder]]) - db2 (d/db conn) - _ @(d/transact conn [[:db.fn/retractEntity [:eacl/id "eacl.relation::account::owner::user"]]]) - db3 (d/db conn)] - - (testing "a single-component edit rewrites the composite tuple in the SAME tx" - (let [t2 (d/basis-t db2) - rows (set (hist-rows db2))] - (is (contains? rows [[:account :holder :user] true t2])) - (is (contains? rows [[:account :owner :user] false t2])))) - - (testing "retractEntity retracts the tuple into history" - (is (contains? (set (hist-rows db3)) - [[:account :holder :user] false (d/basis-t db3)]))) - - (testing "(d/history (d/as-of db t)) is filtered to <= t" - (is (= [[[:account :owner :user] true (d/basis-t db1)]] - (hist-rows (d/as-of db3 (d/basis-t db1)))))) + _ (schema/write-schema! conn schema-v2) + db2 (d/db conn)] - (testing "(d/basis-t (d/as-of db t)) returns the UNDERLYING basis — the digest filter must use d/as-of-t" - (is (= (d/basis-t db3) (d/basis-t (d/as-of db3 (d/basis-t db1))))) - (is (= (d/basis-t db1) (d/as-of-t (d/as-of db3 (d/basis-t db1)))))) - - (testing "d/history works on d/with db-afters and includes speculative datoms" - (let [dbw (:db-after (d/with db3 [(Relation :x :y :z)]))] - (is (some (fn [[v added _t]] (and (= v [:x :y :z]) added)) - (hist-rows dbw))))) - - (testing ".id returns the same database UUID on plain/as-of/with views" - (is (= (str (.id db3)) - (str (.id (d/as-of db3 (d/basis-t db1)))) - (str (.id (:db-after (d/with db3 []))))))) + (testing ".id returns the same database UUID on plain/as-of/with views (scope key component)" + (is (= (str (.id db2)) + (str (.id (d/as-of db2 (d/basis-t db1)))) + (str (.id (:db-after (d/with db2 []))))))) (testing "view classification predicates identify their views; with-dbs read as plain" - (is (false? (d/is-filtered db3))) - (is (false? (d/is-filtered (d/as-of db3 (d/basis-t db1))))) - (is (false? (d/is-filtered (d/since db3 (d/basis-t db1))))) - (is (true? (d/is-filtered (d/filter db3 (fn [_ _] true))))) - (is (true? (d/is-history (d/history db3)))) - (is (false? (d/is-history db3))) - (is (nil? (d/as-of-t (:db-after (d/with db3 []))))) - (is (nil? (d/since-t (:db-after (d/with db3 []))))) - (is (some? (d/since-t (d/since db3 (d/basis-t db1)))))) - - (testing "d/history on a d/filter db RESPECTS the filter" - ;; NOTE: an earlier audit pass concluded the opposite from a vacuous - ;; all-pass predicate (both behaviors coincide for it). Pinned with a - ;; hide-everything predicate instead. Filter views are still never - ;; cached: predicates are arbitrary functions (possibly impure or - ;; time-dependent), so their digests are not trustworthy as shared keys. - (let [hide-everything (d/filter db3 (fn [_ _] false))] - (is (zero? (count (hist-rows hide-everything)))))) - - (testing "d/history on a d/since db is since-filtered" - (is (< (count (hist-rows (d/since db3 (d/basis-t db1)))) - (count (hist-rows db3))))) - - (testing "Db equality is value- and content-based (safe to key the digest memo by db value)" - (is (.equals db3 (d/db conn))) - (let [wa (:db-after (d/with db3 [(Relation :wa :r :user)])) - wb (:db-after (d/with db3 [(Relation :wb :r :user)]))] - (is (false? (.equals wa wb)) - "different-content with-dbs at the same t must not be equal")))))) - -(deftest programmatic-schema-change-invalidation-test - ;; Audit §3: with (.id db)-keyed caches, a permission revoked via plain - ;; d/transact kept GRANTING ACCESS from cache. Invalidation is now derived - ;; from the schema history digest — no helper, no eviction, any peer. + (is (false? (d/is-filtered db2))) + (is (false? (d/is-filtered (d/as-of db2 (d/basis-t db1))))) + (is (false? (d/is-filtered (d/since db2 (d/basis-t db1))))) + (is (true? (d/is-filtered (d/filter db2 (fn [_ _] true))))) + (is (true? (d/is-history (d/history db2)))) + (is (false? (d/is-history db2))) + (is (nil? (d/as-of-t (:db-after (d/with db2 []))))) + (is (nil? (d/since-t (:db-after (d/with db2 []))))) + (is (some? (d/since-t (d/since db2 (d/basis-t db1)))))) + + (testing "the version datom is a plain cardinality-one assert: as-of views read their era's value" + (is (some? (idx/schema-version db1))) + (is (not= (idx/schema-version db1) (idx/schema-version db2))) + (is (= (idx/schema-version db1) + (idx/schema-version (d/as-of db2 (d/basis-t db1))))))))) + +(deftest write-schema-invalidation-test + ;; Audit §3 regression, reworked for issue #74: invalidation is signaled by + ;; write-schema!'s version bump (visible to every peer via the db), not + ;; derived from db content and not dependent on the local eviction. (with-mem-conn [conn schema/v6-schema] - @(d/transact conn [(Relation :account :owner :user) - (Permission :account :admin {:relation :owner})]) + (schema/write-schema! conn schema-v1) @(d/transact conn [{:db/id "u" :eacl/id "u"} {:db/id "a" :eacl/id "a"}]) @(d/transact conn (impl/tx-relationship (d/db conn) (Relationship (spice-object :user [:eacl/id "u"]) @@ -109,78 +74,35 @@ (is (true? (idx/can? db1 u :admin a))) (is (= 1 (count (idx/get-permission-paths db1 :account :admin))) "cache populated") - @(d/transact conn [[:db.fn/retractEntity - [:eacl/id "eacl:permission::account::admin::self::relation::owner"]]]) - (let [db2 (d/db conn)] - (testing "the revoked permission no longer grants access — no manual eviction" - (is (= 0 (count (idx/get-permission-paths db2 :account :admin)))) - (is (false? (idx/can? db2 u :admin a)))) - - (testing "as-of at the pre-change basis resolves the HISTORICAL paths, even after both were cached" - (is (= 1 (count (idx/get-permission-paths (d/as-of db2 (d/basis-t db1)) :account :admin)))) - (is (= 0 (count (idx/get-permission-paths db2 :account :admin))))))))) - -(deftest mutation-classes-change-digest-test - ;; Executable coverage invariant: every mutation class of both schema entity - ;; kinds must change the digest. - (with-mem-conn [conn schema/v6-schema] - @(d/transact conn [(Relation :account :owner :user) - (Permission :account :admin {:relation :owner})]) - (let [digests (atom [(idx/schema-basis-digest (d/db conn))]) - snap! (fn [] (swap! digests conj (idx/schema-basis-digest (d/db conn))))] - ;; add relation - @(d/transact conn [(Relation :account :viewer :user)]) - (snap!) - ;; edit relation component - @(d/transact conn [[:db/add [:eacl/id "eacl.relation::account::viewer::user"] - :eacl.relation/relation-name :viewer2]]) - (snap!) - ;; retract relation - @(d/transact conn [[:db.fn/retractEntity [:eacl/id "eacl.relation::account::viewer::user"]]]) - (snap!) - ;; add permission - @(d/transact conn [(Permission :account :view {:relation :owner})]) - (snap!) - ;; edit permission component - @(d/transact conn [[:db/add [:eacl/id "eacl:permission::account::view::self::relation::owner"] - :eacl.permission/target-name :viewer]]) - (snap!) - ;; retract permission - @(d/transact conn [[:db.fn/retractEntity [:eacl/id "eacl:permission::account::view::self::relation::owner"]]]) - (snap!) - (is (every? string? @digests)) - (is (= (count @digests) (count (distinct @digests))) - "each mutation class must produce a distinct digest")))) - -(deftest speculative-and-filtered-views-cannot-poison-cache-test - (with-mem-conn [conn schema/v6-schema] - @(d/transact conn [(Relation :account :owner :user) - (Permission :account :admin {:relation :owner})]) - (let [db (d/db conn) - perm-lookup-ref [:eacl/id "eacl:permission::account::admin::self::relation::owner"]] - - (testing "a d/with speculative schema edit computes its own paths and leaves the real db's entry intact" - (idx/evict-permission-paths-cache!) - (let [real-paths (idx/get-permission-paths db :account :admin) - dbw (:db-after (d/with db [[:db.fn/retractEntity perm-lookup-ref]])) - spec-paths (idx/get-permission-paths dbw :account :admin)] - (is (= 1 (count real-paths))) - (is (= 0 (count spec-paths))) - (is (= real-paths (idx/get-permission-paths db :account :admin)) - "the real db still resolves its own paths after the speculative computation"))) - - (testing "a d/filter db hiding the permission cannot publish empty paths under the plain db's key" - (idx/evict-permission-paths-cache!) - (let [perm-eid (d/entid db perm-lookup-ref) - filtered (d/filter db (fn [_db datom] (not= perm-eid (:e datom)))) - filt-paths (idx/get-permission-paths filtered :account :admin)] - (is (= 0 (count filt-paths)) "the filtered view itself must not see the permission") - (is (= 1 (count (idx/get-permission-paths db :account :admin))) - "the plain db, queried AFTER the filtered view, must still see it") - (is (nil? (idx/schema-basis-digest filtered)) - "filter views are unclassifiable and never share the cache")))))) - -(deftest unchanged-schema-cache-hit-test + (testing "write-schema! invalidates via the version key alone — no local eviction needed (the cross-peer story)" + (with-redefs [idx/evict-permission-paths-cache! (fn [] nil)] + (schema/write-schema! conn schema-v2)) + (let [db2 (d/db conn)] + (is (= 2 (count (idx/get-permission-paths db2 :account :admin))) + "new version, new cache slot: paths recomputed without eviction") + (is (true? (idx/can? db2 u :admin a))) + + (testing "as-of at the pre-change basis resolves the HISTORICAL paths, even after both were cached" + (is (= 1 (count (idx/get-permission-paths (d/as-of db2 (d/basis-t db1)) :account :admin)))) + (is (= 2 (count (idx/get-permission-paths db2 :account :admin))))))) + + (testing "programmatic schema edits are invisible to the caches — by design (issue #74)" + (let [viewer-perm-eid (d/q '[:find ?e . + :where + [?e :eacl.permission/resource-type :account] + [?e :eacl.permission/permission-name :admin] + [?e :eacl.permission/target-name :viewer]] + (d/db conn))] + @(d/transact conn [[:db.fn/retractEntity viewer-perm-eid]]) + (is (= 2 (count (idx/get-permission-paths (d/db conn) :account :admin))) + "raw d/transact did not bump the version: stale paths served until the next write-schema!") + (idx/evict-permission-paths-cache!) + (is (= 1 (count (idx/get-permission-paths (d/db conn) :account :admin))) + "manual evict-permission-paths-cache! is the recovery hatch")))))) + +(deftest unrelated-transact-keeps-cache-test + ;; Issue #74 itself: relationship/application writes must not bust the path + ;; cache — neither before any write-schema! (nil version) nor after one. (with-mem-conn [conn schema/v6-schema] @(d/transact conn [(Relation :account :owner :user) (Permission :account :admin {:relation :owner})]) @@ -191,13 +113,51 @@ (with-redefs [idx/calc-permission-paths (fn [& args] (swap! calls inc) (apply orig args))] - (idx/get-permission-paths (d/db conn) :account :admin) - (is (= 1 @calls)) - ;; unrelated (non-schema) relationship write between queries - @(d/transact conn (impl/tx-relationship (d/db conn) - (Relationship (spice-object :user [:eacl/id "u"]) - :owner - (spice-object :account [:eacl/id "a"])))) - (idx/get-permission-paths (d/db conn) :account :admin) - (is (= 1 @calls) - "unchanged schema across relationship writes must hit the cache"))))) + (testing "pre-version databases (no write-schema! yet) still cache across unrelated writes" + (idx/get-permission-paths (d/db conn) :account :admin) + (is (= 1 @calls)) + @(d/transact conn (impl/tx-relationship (d/db conn) + (Relationship (spice-object :user [:eacl/id "u"]) + :owner + (spice-object :account [:eacl/id "a"])))) + (idx/get-permission-paths (d/db conn) :account :admin) + (is (= 1 @calls) + "unchanged schema across relationship writes must hit the cache")) + + (testing "after write-schema!, the version stays put across unrelated writes: cache stays hot" + (schema/write-schema! conn schema-v1) + (idx/get-permission-paths (d/db conn) :account :admin) + (let [warm @calls] + @(d/transact conn [{:eacl/id "unrelated-entity"}]) + @(d/transact conn (impl/tx-relationship (d/db conn) + (Relationship (spice-object :user [:eacl/id "u"]) + :owner + (spice-object :account [:eacl/id "unrelated-entity"])))) + (idx/get-permission-paths (d/db conn) :account :admin) + (is (= warm @calls) + "d/transact of relationships/entities must not recompute paths (issue #74)"))))))) + +(deftest filtered-views-cannot-poison-cache-test + (with-mem-conn [conn schema/v6-schema] + (schema/write-schema! conn schema-v1) + (let [db (d/db conn) + perm-eid (d/q '[:find ?e . + :where + [?e :eacl.permission/resource-type :account] + [?e :eacl.permission/permission-name :admin]] + db)] + (testing "a d/filter db hiding the permission cannot publish empty paths under the plain db's key" + (idx/evict-permission-paths-cache!) + (let [filtered (d/filter db (fn [_db datom] (not= perm-eid (:e datom)))) + filt-paths (idx/get-permission-paths filtered :account :admin)] + (is (= 0 (count filt-paths)) "the filtered view itself must not see the permission") + (is (= 1 (count (idx/get-permission-paths db :account :admin))) + "the plain db, queried AFTER the filtered view, must still see it") + (is (nil? (idx/schema-version-stamp filtered)) + "filter views are unclassifiable and never share the cache"))) + + (testing "since and history views are likewise unclassifiable" + (is (nil? (idx/schema-version-stamp (d/since db 0)))) + (is (nil? (idx/schema-version-stamp (d/history db)))) + (is (some? (idx/schema-version-stamp db))) + (is (some? (idx/schema-version-stamp (d/as-of db (d/basis-t db))))))))) From 9c291760ec47040ecdfef09de922e432f168a6c5 Mon Sep 17 00:00:00 2001 From: Petrus Theron Date: Tue, 14 Jul 2026 18:22:53 +0200 Subject: [PATCH 06/13] fix #74 (modules): schema-version stamp replaces derived digest in eacl-datomic MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Port of the top-level revert (cherry-picked in the previous commit) to the modular Datomic backend: - modules/eacl-datomic indexed.clj: schema-cache-scope now returns [(.id db) schema-version] read via one AVET lookup — no history scans, no per-db-value memo. The scope feeds both the shared engine's path-cache keys and cursor fingerprints via :cache-stamp, so unrelated d/transact calls never invalidate either. Sentinel scopes for filter/since/history views now carry a string UUID (was a bare Object) so a cursor minted on an unclassifiable view still round-trips through token encoding. - modules/eacl-datomic schema.clj: v7-schema installs :eacl/schema-version; write-schema! installs it just-in-time on older databases and asserts a fresh squuid when the definition delta is non-empty. - schema_basis_test.clj rewritten to pin the new contract (same tests as the top-level lineage). The DataScript backend is untouched: its ds/listen! stamp already bumps only when a transaction touches schema attributes. The shared cljc engine is untouched (the spi/cache-stamp contract is unchanged), so no CLJS changes. Cold clj -X:test (all modules): 55 tests, 873 assertions, 0 failures. Co-Authored-By: Claude Fable 5 --- README.md | 4 +- .../src/eacl/datomic/impl/indexed.clj | 107 ++++--- .../eacl-datomic/src/eacl/datomic/schema.clj | 34 ++- .../test/eacl/datomic/schema_basis_test.clj | 286 ++++++++---------- 4 files changed, 208 insertions(+), 223 deletions(-) diff --git a/README.md b/README.md index 15c258c3b..9f2bc86a7 100644 --- a/README.md +++ b/README.md @@ -44,7 +44,7 @@ Situated AuthZ offers some advantages for typical use-cases: - The performance goal for EACL is to handle 10M permissioned entities with real-time performance. - EACL does not support all SpiceDB features. Please refer to the [limitations section](#limitations-deficiencies--gotchas) to decide if EACL is right for you. - Presently, EACL has _no result cache_ because graph traversal is fast enough over Datomic's aggressive datom caching even for ~1M permissioned resources. A cache is planned and once it lands, should bring query latency down to ~1-2ms per API call, even for large pages. -- EACL does cache resolved *permission paths and query plans*. Invalidation is fully automatic for **all** schema writes — `write-schema!`, programmatic transactions, retractions, even excision — on every peer and for `d/as-of` views: cache keys carry a digest of the schema's history read from the db value being queried, so no writer-side signal or eviction call is required. The digest scan is O(all-time schema edits) once per db value (identity-memoized); if you continuously churn schema at high volume (an ops smell), expect that scan to grow linearly. +- EACL does cache resolved *permission paths and query plans*. The cache is invalidated **only by `eacl/write-schema!`**, which bumps a schema-version stamp (`:eacl/schema-version`) stored in the database in the same transaction as the definition change — so invalidation reaches every peer, `d/as-of` views resolve the paths of their own era, and unrelated `d/transact` calls never touch a cache key (zero per-transaction overhead — issue #74). Editing relation/permission datoms outside `write-schema!` is not detected by design; if you must, call `eacl.datomic.impl.indexed/evict-permission-paths-cache!` on every peer afterwards. - Recursive `lookup-resources` cursors carry the recursion state and grow ~48 bytes per emitted resource, because exact cross-page deduplication requires the emitted set. Prefer bounded pagination sessions on recursive schemas; a cursor-state redesign is planned. - Performance should scale roughly with permission graph complexity * `O(logN)` for `N` resources in terminal resource Relationship indices. Parallel paths through the graph that return the same resources will slow EACL down, because these resources need to be deduplicated in stable order. In a simple graph, performance should approach `O(logN)` for N permissioned resources. Subjects are typically sparse compared to resources, i.e. 1k users will have access to 1M resources – rarely the other way around. @@ -591,6 +591,8 @@ EACL uses the SpiceDB schema DSL. Use `eacl/write-schema!` to define your schema For advanced use cases, you can also define schema programmatically using the internal `Relation` and `Permission` functions: +> **Cache caveat:** transacting `Relation`/`Permission` datoms directly bypasses `write-schema!`'s cache invalidation (see the caching note above). After a programmatic schema change, call `(eacl.datomic.impl.indexed/evict-permission-paths-cache!)` on every peer — or prefer `write-schema!`, which handles this for you. + ```clojure (require '[eacl.datomic.impl :refer [Relation Permission]]) diff --git a/modules/eacl-datomic/src/eacl/datomic/impl/indexed.clj b/modules/eacl-datomic/src/eacl/datomic/impl/indexed.clj index e2d525b14..968f9060a 100644 --- a/modules/eacl-datomic/src/eacl/datomic/impl/indexed.clj +++ b/modules/eacl-datomic/src/eacl/datomic/impl/indexed.clj @@ -94,33 +94,47 @@ (defn evict-permission-paths-cache! [] (engine/evict-permission-paths-cache! permission-paths-cache)) -;; --- Schema-history digest cache stamp (audit 3 / D8) ---------------------- +;; --- Schema-version cache stamp (issue #74) --------------------------------- ;; -;; Coverage invariant: every attribute that permission-path computation reads -;; MUST be a component of one of the composite tuples digested below. Datomic -;; rewrites a composite tuple datom in the same transaction as ANY component -;; change, and retractEntity retracts it, so the tuple histories are a complete -;; record of path-relevant schema mutations. Any schema mutation - write-schema!, -;; programmatic transaction, retraction, or excision - changes the digest, on -;; every peer, for d/as-of views, with no writer-side signal. +;; The path caches are invalidated ONLY by eacl.datomic.schema/write-schema!, +;; which asserts a fresh :eacl/schema-version squuid on the schema singleton in +;; the same transaction as any definition change. Reading the stamp is a single +;; AVET lookup - O(log N), no history scans - and unrelated d/transact calls +;; leave it (and therefore every cache key) untouched, so relationship write +;; load can never evict or recompute paths. (The previous design derived a +;; digest from schema history per db basis, i.e. recomputed after every +;; transact - issue #74.) +;; +;; Contract: permission schema mutations MUST go through write-schema!. +;; Programmatic edits of relation/permission datoms (raw d/transact, d/with, +;; excision) do not bump the version, so caches and cursors may serve paths +;; computed from the pre-edit schema until the next write-schema! or a manual +;; evict-permission-paths-cache!. That trade-off is by design. +;; +;; The stamp lives in the database, not in peer memory, so write-schema! on any +;; peer invalidates every peer; d/as-of views read the version that was current +;; at that basis (audit 3 fix, preserved); a squuid can never be re-asserted to +;; an unchanged value by a concurrent writer (no counter-elision race); and +;; cursor fingerprints survive process restarts. -(def ^:private schema-digest-attrs - [:eacl.relation/resource-type+relation-name+subject-type - :eacl.permission/resource-type+source-relation-name+target-type+target-name+permission-name]) +(def schema-version-attr + "Installed by eacl.datomic.schema/v7-schema; asserted by write-schema!." + :eacl/schema-version) -(defonce ^:private schema-scope-memo - ;; Keyed by the db value itself: Datomic Db equality is value- and - ;; content-based (pinned by tests), so this can only unify db values whose - ;; visible histories - and therefore digests - are identical. Weak keys - ;; release with the db value. Sentinel (uncached) scopes are never stored. - (java.util.Collections/synchronizedMap (java.util.WeakHashMap.))) +(defn schema-version + "The schema-version squuid asserted by the most recent write-schema! visible + in this db value, or nil for databases that predate versioned schema writes. + A single AVET lookup on a one-datom attribute." + [db] + (when (d/entid db schema-version-attr) + (:v (first (d/datoms db :avet schema-version-attr))))) (defn- classified-view - "Positively classifies a db value: :plain, :as-of, or nil for anything the - digest must not be shared for. d/filter views are excluded because their - predicates are arbitrary functions (possibly impure or time-dependent), so a - digest of their filtered history is not trustworthy as a shared cache key; - d/since views hide old schema; history views are not queryable schema states." + "Positively classifies a db value: :plain, :as-of, or nil for any view the + version stamp cannot be trusted on. d/filter views are excluded because their + predicates are arbitrary functions that may hide definition datoms without + hiding the version datom; d/since views hide old schema; history views are + not queryable schema states." [db] (cond (d/is-history db) nil @@ -129,41 +143,24 @@ (some? (d/as-of-t db)) :as-of :else :plain)) -(defn- schema-history-digest - "128-bit hex digest (SHA-256 truncated; FIPS-safe) folded in index order over - the history datoms of the schema composite tuple attrs, filtered to the db's - visible basis. NOTE: d/basis-t of an as-of view returns the UNDERLYING basis - (pinned by tests), so the visibility filter must prefer d/as-of-t." - [db] - (let [md (java.security.MessageDigest/getInstance "SHA-256") - limit-t (or (d/as-of-t db) (d/basis-t db)) - hist (d/history db)] - (doseq [attr schema-digest-attrs - datom (d/datoms hist :aevt attr) - :let [t (d/tx->t (:tx datom))] - :when (<= t limit-t)] - (.update md (.getBytes ^String (pr-str [(:e datom) (:v datom) t (:added datom)]) "UTF-8"))) - (format "%032x" (java.math.BigInteger. 1 (java.util.Arrays/copyOf (.digest md) 16))))) - (defn schema-cache-scope - "Returns [database-id schema-history-digest] for positively classified + "Returns [database-id schema-version-string] for positively classified plain/as-of db values, or a fresh unique sentinel for anything else and for ANY failure. Sentinel scopes make every cache key unique: every failure mode - degrades to recomputation from the queried db value - never staleness." + degrades to recomputation from the queried db value - never staleness. The + sentinel's unique component is a string (not an Object) so a cursor + fingerprint minted on an unclassifiable view still round-trips through + token encoding." [db] - (or (.get ^java.util.Map schema-scope-memo db) - (let [scope (try - (when (classified-view db) - [(str (.id db)) (schema-history-digest db)]) - (catch Throwable _ nil))] - (if scope - (do (.put ^java.util.Map schema-scope-memo db scope) - scope) - [::uncached (Object.)])))) + (or (try + (when (classified-view db) + [(str (.id db)) (some-> (schema-version db) str)]) + (catch Throwable _ nil)) + [::uncached (str (java.util.UUID/randomUUID))])) -(defn schema-basis-digest - "The schema-history digest for this db value, or nil when the view cannot be - cached (see schema-cache-scope)." +(defn schema-version-stamp + "String form of the schema version for this db value, or nil when no version + has been written yet or the view cannot be classified (see schema-cache-scope)." [db] (let [scope (schema-cache-scope db)] (when-not (= ::uncached (first scope)) @@ -180,9 +177,9 @@ (defn indexed-backend [db] {:cache-stamp (fn [] - ;; Content-derived schema scope (audit 3): identityHashCode - ;; keyed one cache entry per db OBJECT (a near-always-miss - ;; cache) and could collide across GC address reuse. + ;; [db-id schema-version] - bumped only by write-schema! + ;; (issue #74), so unrelated d/transact calls never change + ;; cache keys or cursor fingerprints. One AVET lookup. (schema-cache-scope db)) :relation-defs (fn [resource-type relation-name] (mapv (fn [datom] diff --git a/modules/eacl-datomic/src/eacl/datomic/schema.clj b/modules/eacl-datomic/src/eacl/datomic/schema.clj index ffdc47720..5fb872be7 100644 --- a/modules/eacl-datomic/src/eacl/datomic/schema.clj +++ b/modules/eacl-datomic/src/eacl/datomic/schema.clj @@ -36,6 +36,19 @@ ;(def Permission ; [:or DirectPermission ArrowPermission]) +(def schema-version-attr-definition + "Cache-invalidation stamp. write-schema! asserts a fresh squuid here in the + same transaction as any definition change; EACL's permission-path caches and + cursor fingerprints key on it, so ONLY write-schema! invalidates them (#74). + A squuid (not a counter) so two concurrent writers can never assert the same + value and elide each other's invalidation. Do not edit EACL definitions + outside write-schema! — the stamp will not change and caches will be stale." + {:db/ident :eacl/schema-version + :db/doc "Squuid bumped by write-schema! whenever definitions change. Path caches and cursor fingerprints key on it." + :db/valueType :db.type/uuid + :db/cardinality :db.cardinality/one + :db/index true}) + (def v7-schema [; :eacl/id is now optional. {:db/ident :eacl/id ; todo: figure out how to support :id, :object/id or :spice/id of different types. @@ -49,6 +62,8 @@ :db/valueType :db.type/string :db/cardinality :db.cardinality/one} + schema-version-attr-definition + ;; Relations {:db/ident :eacl.relation/resource-type :db/doc "EACL Relation: Resource Type" @@ -249,6 +264,9 @@ ([conn schema-string] (write-schema! conn schema-string {})) ([conn schema-string {:keys [allow-empty-schema?]}] + ;; Upgrade path: databases installed before :eacl/schema-version existed. + (when-not (d/entid (d/db conn) :eacl/schema-version) + @(d/transact conn [schema-version-attr-definition])) (let [new-schema-map (parser/->eacl-schema (parser/parse-schema schema-string)) ;; Validate schema references before proceeding (ADR 012 requirement) _ (validate-schema-references new-schema-map) @@ -277,7 +295,11 @@ {:relation rel :count cnt}))))) ;; Transact changes - (let [tx-data (concat + (let [schema-changed? (boolean (or (seq (:additions relations)) + (seq relation-retractions) + (seq (:additions permissions)) + (seq permission-retractions))) + tx-data (concat ;; Additions (:additions relations) (:additions permissions) @@ -286,9 +308,13 @@ [:db.fn/retractEntity [:eacl/id (:eacl/id rel)]]) (for [perm permission-retractions] [:db.fn/retractEntity [:eacl/id (:eacl/id perm)]]) - ;; Store schema string - [{:eacl/id "schema-string" - :eacl/schema-string schema-string}])] + ;; Store schema string + bump the version stamp when + ;; definitions changed. The stamp is what invalidates the + ;; path caches and cursor fingerprints — on every peer, + ;; and correctly for d/as-of views (issue #74). + [(cond-> {:eacl/id "schema-string" + :eacl/schema-string schema-string} + schema-changed? (assoc :eacl/schema-version (d/squuid)))])] @(d/transact conn tx-data) (impl.indexed/evict-permission-paths-cache!) deltas)))) diff --git a/modules/eacl-datomic/test/eacl/datomic/schema_basis_test.clj b/modules/eacl-datomic/test/eacl/datomic/schema_basis_test.clj index 89ae87e2d..89281815d 100644 --- a/modules/eacl-datomic/test/eacl/datomic/schema_basis_test.clj +++ b/modules/eacl-datomic/test/eacl/datomic/schema_basis_test.clj @@ -1,8 +1,13 @@ (ns eacl.datomic.schema-basis-test - "Pins the Datomic behaviors the schema-digest cache scope (D8) relies on, - plus regressions for the cache-staleness bugs from the 2026-07-06 audit (§3). - A peer upgrade that changes any pinned behavior must fail loudly here — - every one was REPL-verified against peer 1.0.6733." + "Pins the write-schema!-driven cache-invalidation contract (issue #74) and + the Datomic view-classification facts the cache scope relies on, plus the + audit §3 regression (no cache-slot sharing across db bases). + + The contract: ONLY eacl.datomic.schema/write-schema! invalidates the + permission-path caches — it bumps :eacl/schema-version in the same + transaction as any definition change. Unrelated d/transact calls must leave + every cache key untouched. Programmatic edits of relation/permission datoms + bypass the stamp and are explicitly unsupported (issue #74)." (:require [clojure.test :refer [deftest testing is]] [datomic.api :as d] [eacl.core :refer [spice-object]] @@ -11,92 +16,52 @@ [eacl.datomic.impl.indexed :as idx] [eacl.datomic.schema :as schema])) -(def ^:private rel-tuple-attr :eacl.relation/resource-type+relation-name+subject-type) +(def ^:private schema-v1 + "definition user {} + definition account { relation owner: user + permission admin = owner }") -(defn- hist-rows - [db] - (->> (d/datoms (d/history db) :aevt rel-tuple-attr) - (map (juxt :v :added (comp d/tx->t :tx))) - (sort-by last) - (vec))) +(def ^:private schema-v2 + "definition user {} + definition account { relation owner: user + relation viewer: user + permission admin = owner + viewer }") (deftest pinned-datomic-behaviors-test (with-mem-conn [conn schema/v6-schema] - @(d/transact conn [(Relation :account :owner :user) - (Permission :account :admin {:relation :owner})]) + (schema/write-schema! conn schema-v1) (let [db1 (d/db conn) - _ @(d/transact conn [[:db/add [:eacl/id "eacl.relation::account::owner::user"] - :eacl.relation/relation-name :holder]]) - db2 (d/db conn) - _ @(d/transact conn [[:db.fn/retractEntity [:eacl/id "eacl.relation::account::owner::user"]]]) - db3 (d/db conn)] - - (testing "a single-component edit rewrites the composite tuple in the SAME tx" - (let [t2 (d/basis-t db2) - rows (set (hist-rows db2))] - (is (contains? rows [[:account :holder :user] true t2])) - (is (contains? rows [[:account :owner :user] false t2])))) - - (testing "retractEntity retracts the tuple into history" - (is (contains? (set (hist-rows db3)) - [[:account :holder :user] false (d/basis-t db3)]))) - - (testing "(d/history (d/as-of db t)) is filtered to <= t" - (is (= [[[:account :owner :user] true (d/basis-t db1)]] - (hist-rows (d/as-of db3 (d/basis-t db1)))))) + _ (schema/write-schema! conn schema-v2) + db2 (d/db conn)] - (testing "(d/basis-t (d/as-of db t)) returns the UNDERLYING basis — the digest filter must use d/as-of-t" - (is (= (d/basis-t db3) (d/basis-t (d/as-of db3 (d/basis-t db1))))) - (is (= (d/basis-t db1) (d/as-of-t (d/as-of db3 (d/basis-t db1)))))) - - (testing "d/history works on d/with db-afters and includes speculative datoms" - (let [dbw (:db-after (d/with db3 [(Relation :x :y :z)]))] - (is (some (fn [[v added _t]] (and (= v [:x :y :z]) added)) - (hist-rows dbw))))) - - (testing ".id returns the same database UUID on plain/as-of/with views" - (is (= (str (.id db3)) - (str (.id (d/as-of db3 (d/basis-t db1)))) - (str (.id (:db-after (d/with db3 []))))))) + (testing ".id returns the same database UUID on plain/as-of/with views (scope key component)" + (is (= (str (.id db2)) + (str (.id (d/as-of db2 (d/basis-t db1)))) + (str (.id (:db-after (d/with db2 []))))))) (testing "view classification predicates identify their views; with-dbs read as plain" - (is (false? (d/is-filtered db3))) - (is (false? (d/is-filtered (d/as-of db3 (d/basis-t db1))))) - (is (false? (d/is-filtered (d/since db3 (d/basis-t db1))))) - (is (true? (d/is-filtered (d/filter db3 (fn [_ _] true))))) - (is (true? (d/is-history (d/history db3)))) - (is (false? (d/is-history db3))) - (is (nil? (d/as-of-t (:db-after (d/with db3 []))))) - (is (nil? (d/since-t (:db-after (d/with db3 []))))) - (is (some? (d/since-t (d/since db3 (d/basis-t db1)))))) - - (testing "d/history on a d/filter db RESPECTS the filter" - ;; NOTE: an earlier audit pass concluded the opposite from a vacuous - ;; all-pass predicate (both behaviors coincide for it). Pinned with a - ;; hide-everything predicate instead. Filter views are still never - ;; cached: predicates are arbitrary functions (possibly impure or - ;; time-dependent), so their digests are not trustworthy as shared keys. - (let [hide-everything (d/filter db3 (fn [_ _] false))] - (is (zero? (count (hist-rows hide-everything)))))) - - (testing "d/history on a d/since db is since-filtered" - (is (< (count (hist-rows (d/since db3 (d/basis-t db1)))) - (count (hist-rows db3))))) - - (testing "Db equality is value- and content-based (safe to key the digest memo by db value)" - (is (.equals db3 (d/db conn))) - (let [wa (:db-after (d/with db3 [(Relation :wa :r :user)])) - wb (:db-after (d/with db3 [(Relation :wb :r :user)]))] - (is (false? (.equals wa wb)) - "different-content with-dbs at the same t must not be equal")))))) - -(deftest programmatic-schema-change-invalidation-test - ;; Audit §3: with (.id db)-keyed caches, a permission revoked via plain - ;; d/transact kept GRANTING ACCESS from cache. Invalidation is now derived - ;; from the schema history digest — no helper, no eviction, any peer. + (is (false? (d/is-filtered db2))) + (is (false? (d/is-filtered (d/as-of db2 (d/basis-t db1))))) + (is (false? (d/is-filtered (d/since db2 (d/basis-t db1))))) + (is (true? (d/is-filtered (d/filter db2 (fn [_ _] true))))) + (is (true? (d/is-history (d/history db2)))) + (is (false? (d/is-history db2))) + (is (nil? (d/as-of-t (:db-after (d/with db2 []))))) + (is (nil? (d/since-t (:db-after (d/with db2 []))))) + (is (some? (d/since-t (d/since db2 (d/basis-t db1)))))) + + (testing "the version datom is a plain cardinality-one assert: as-of views read their era's value" + (is (some? (idx/schema-version db1))) + (is (not= (idx/schema-version db1) (idx/schema-version db2))) + (is (= (idx/schema-version db1) + (idx/schema-version (d/as-of db2 (d/basis-t db1))))))))) + +(deftest write-schema-invalidation-test + ;; Audit §3 regression, reworked for issue #74: invalidation is signaled by + ;; write-schema!'s version bump (visible to every peer via the db), not + ;; derived from db content and not dependent on the local eviction. (with-mem-conn [conn schema/v6-schema] - @(d/transact conn [(Relation :account :owner :user) - (Permission :account :admin {:relation :owner})]) + (schema/write-schema! conn schema-v1) @(d/transact conn [{:db/id "u" :eacl/id "u"} {:db/id "a" :eacl/id "a"}]) @(d/transact conn (impl/tx-relationship (d/db conn) (Relationship (spice-object :user [:eacl/id "u"]) @@ -109,78 +74,35 @@ (is (true? (idx/can? db1 u :admin a))) (is (= 1 (count (idx/get-permission-paths db1 :account :admin))) "cache populated") - @(d/transact conn [[:db.fn/retractEntity - [:eacl/id "eacl:permission::account::admin::self::relation::owner"]]]) - (let [db2 (d/db conn)] - (testing "the revoked permission no longer grants access — no manual eviction" - (is (= 0 (count (idx/get-permission-paths db2 :account :admin)))) - (is (false? (idx/can? db2 u :admin a)))) - - (testing "as-of at the pre-change basis resolves the HISTORICAL paths, even after both were cached" - (is (= 1 (count (idx/get-permission-paths (d/as-of db2 (d/basis-t db1)) :account :admin)))) - (is (= 0 (count (idx/get-permission-paths db2 :account :admin))))))))) - -(deftest mutation-classes-change-digest-test - ;; Executable coverage invariant: every mutation class of both schema entity - ;; kinds must change the digest. - (with-mem-conn [conn schema/v6-schema] - @(d/transact conn [(Relation :account :owner :user) - (Permission :account :admin {:relation :owner})]) - (let [digests (atom [(idx/schema-basis-digest (d/db conn))]) - snap! (fn [] (swap! digests conj (idx/schema-basis-digest (d/db conn))))] - ;; add relation - @(d/transact conn [(Relation :account :viewer :user)]) - (snap!) - ;; edit relation component - @(d/transact conn [[:db/add [:eacl/id "eacl.relation::account::viewer::user"] - :eacl.relation/relation-name :viewer2]]) - (snap!) - ;; retract relation - @(d/transact conn [[:db.fn/retractEntity [:eacl/id "eacl.relation::account::viewer::user"]]]) - (snap!) - ;; add permission - @(d/transact conn [(Permission :account :view {:relation :owner})]) - (snap!) - ;; edit permission component - @(d/transact conn [[:db/add [:eacl/id "eacl:permission::account::view::self::relation::owner"] - :eacl.permission/target-name :viewer]]) - (snap!) - ;; retract permission - @(d/transact conn [[:db.fn/retractEntity [:eacl/id "eacl:permission::account::view::self::relation::owner"]]]) - (snap!) - (is (every? string? @digests)) - (is (= (count @digests) (count (distinct @digests))) - "each mutation class must produce a distinct digest")))) - -(deftest speculative-and-filtered-views-cannot-poison-cache-test - (with-mem-conn [conn schema/v6-schema] - @(d/transact conn [(Relation :account :owner :user) - (Permission :account :admin {:relation :owner})]) - (let [db (d/db conn) - perm-lookup-ref [:eacl/id "eacl:permission::account::admin::self::relation::owner"]] - - (testing "a d/with speculative schema edit computes its own paths and leaves the real db's entry intact" - (idx/evict-permission-paths-cache!) - (let [real-paths (idx/get-permission-paths db :account :admin) - dbw (:db-after (d/with db [[:db.fn/retractEntity perm-lookup-ref]])) - spec-paths (idx/get-permission-paths dbw :account :admin)] - (is (= 1 (count real-paths))) - (is (= 0 (count spec-paths))) - (is (= real-paths (idx/get-permission-paths db :account :admin)) - "the real db still resolves its own paths after the speculative computation"))) - - (testing "a d/filter db hiding the permission cannot publish empty paths under the plain db's key" - (idx/evict-permission-paths-cache!) - (let [perm-eid (d/entid db perm-lookup-ref) - filtered (d/filter db (fn [_db datom] (not= perm-eid (:e datom)))) - filt-paths (idx/get-permission-paths filtered :account :admin)] - (is (= 0 (count filt-paths)) "the filtered view itself must not see the permission") - (is (= 1 (count (idx/get-permission-paths db :account :admin))) - "the plain db, queried AFTER the filtered view, must still see it") - (is (nil? (idx/schema-basis-digest filtered)) - "filter views are unclassifiable and never share the cache")))))) - -(deftest unchanged-schema-cache-hit-test + (testing "write-schema! invalidates via the version key alone — no local eviction needed (the cross-peer story)" + (with-redefs [idx/evict-permission-paths-cache! (fn [] nil)] + (schema/write-schema! conn schema-v2)) + (let [db2 (d/db conn)] + (is (= 2 (count (idx/get-permission-paths db2 :account :admin))) + "new version, new cache slot: paths recomputed without eviction") + (is (true? (idx/can? db2 u :admin a))) + + (testing "as-of at the pre-change basis resolves the HISTORICAL paths, even after both were cached" + (is (= 1 (count (idx/get-permission-paths (d/as-of db2 (d/basis-t db1)) :account :admin)))) + (is (= 2 (count (idx/get-permission-paths db2 :account :admin))))))) + + (testing "programmatic schema edits are invisible to the caches — by design (issue #74)" + (let [viewer-perm-eid (d/q '[:find ?e . + :where + [?e :eacl.permission/resource-type :account] + [?e :eacl.permission/permission-name :admin] + [?e :eacl.permission/target-name :viewer]] + (d/db conn))] + @(d/transact conn [[:db.fn/retractEntity viewer-perm-eid]]) + (is (= 2 (count (idx/get-permission-paths (d/db conn) :account :admin))) + "raw d/transact did not bump the version: stale paths served until the next write-schema!") + (idx/evict-permission-paths-cache!) + (is (= 1 (count (idx/get-permission-paths (d/db conn) :account :admin))) + "manual evict-permission-paths-cache! is the recovery hatch")))))) + +(deftest unrelated-transact-keeps-cache-test + ;; Issue #74 itself: relationship/application writes must not bust the path + ;; cache — neither before any write-schema! (nil version) nor after one. (with-mem-conn [conn schema/v6-schema] @(d/transact conn [(Relation :account :owner :user) (Permission :account :admin {:relation :owner})]) @@ -191,13 +113,51 @@ (with-redefs [idx/calc-permission-paths (fn [& args] (swap! calls inc) (apply orig args))] - (idx/get-permission-paths (d/db conn) :account :admin) - (is (= 1 @calls)) - ;; unrelated (non-schema) relationship write between queries - @(d/transact conn (impl/tx-relationship (d/db conn) - (Relationship (spice-object :user [:eacl/id "u"]) - :owner - (spice-object :account [:eacl/id "a"])))) - (idx/get-permission-paths (d/db conn) :account :admin) - (is (= 1 @calls) - "unchanged schema across relationship writes must hit the cache"))))) + (testing "pre-version databases (no write-schema! yet) still cache across unrelated writes" + (idx/get-permission-paths (d/db conn) :account :admin) + (is (= 1 @calls)) + @(d/transact conn (impl/tx-relationship (d/db conn) + (Relationship (spice-object :user [:eacl/id "u"]) + :owner + (spice-object :account [:eacl/id "a"])))) + (idx/get-permission-paths (d/db conn) :account :admin) + (is (= 1 @calls) + "unchanged schema across relationship writes must hit the cache")) + + (testing "after write-schema!, the version stays put across unrelated writes: cache stays hot" + (schema/write-schema! conn schema-v1) + (idx/get-permission-paths (d/db conn) :account :admin) + (let [warm @calls] + @(d/transact conn [{:eacl/id "unrelated-entity"}]) + @(d/transact conn (impl/tx-relationship (d/db conn) + (Relationship (spice-object :user [:eacl/id "u"]) + :owner + (spice-object :account [:eacl/id "unrelated-entity"])))) + (idx/get-permission-paths (d/db conn) :account :admin) + (is (= warm @calls) + "d/transact of relationships/entities must not recompute paths (issue #74)"))))))) + +(deftest filtered-views-cannot-poison-cache-test + (with-mem-conn [conn schema/v6-schema] + (schema/write-schema! conn schema-v1) + (let [db (d/db conn) + perm-eid (d/q '[:find ?e . + :where + [?e :eacl.permission/resource-type :account] + [?e :eacl.permission/permission-name :admin]] + db)] + (testing "a d/filter db hiding the permission cannot publish empty paths under the plain db's key" + (idx/evict-permission-paths-cache!) + (let [filtered (d/filter db (fn [_db datom] (not= perm-eid (:e datom)))) + filt-paths (idx/get-permission-paths filtered :account :admin)] + (is (= 0 (count filt-paths)) "the filtered view itself must not see the permission") + (is (= 1 (count (idx/get-permission-paths db :account :admin))) + "the plain db, queried AFTER the filtered view, must still see it") + (is (nil? (idx/schema-version-stamp filtered)) + "filter views are unclassifiable and never share the cache"))) + + (testing "since and history views are likewise unclassifiable" + (is (nil? (idx/schema-version-stamp (d/since db 0)))) + (is (nil? (idx/schema-version-stamp (d/history db)))) + (is (some? (idx/schema-version-stamp db))) + (is (some? (idx/schema-version-stamp (d/as-of db (d/basis-t db))))))))) From 457b137bad63ae248728885d611421f3227aa75c Mon Sep 17 00:00:00 2001 From: Petrus Theron Date: Tue, 28 Jul 2026 19:33:30 +0200 Subject: [PATCH 07/13] Return no cursor for empty first pages Keep the legacy DataScript pagination contract valid on an empty database instead of minting a boundary-less v7.3 cursor that the next request must reject. --- .../test/eacl/datascript/contract_test.cljc | 15 +++++++++++++++ modules/eacl/src/eacl/engine/indexed.cljc | 11 ++++++----- 2 files changed, 21 insertions(+), 5 deletions(-) diff --git a/modules/eacl-datascript/test/eacl/datascript/contract_test.cljc b/modules/eacl-datascript/test/eacl/datascript/contract_test.cljc index 36373b26a..43519955f 100644 --- a/modules/eacl-datascript/test/eacl/datascript/contract_test.cljc +++ b/modules/eacl-datascript/test/eacl/datascript/contract_test.cljc @@ -108,6 +108,21 @@ :subject/type :user :subject/relation :member})))))))) +(deftest v7-3-empty-first-page-test + (let [conn (datascript/create-conn) + client (datascript/make-client conn {}) + query {:subject (contract/->user "user-1") + :permission :view + :resource/type :server + :limit 100}] + (eacl/write-schema! client contract/smoke-schema) + (seed-objects! conn) + (testing "an empty first page does not mint a boundary-less cursor" + (is (= {:data [] :cursor nil} + (eacl/lookup-resources client query))) + (is (= {:count 0 :limit 100 :cursor nil} + (eacl/count-resources client query)))))) + (deftest v7-3-direction-scoped-frontier-test (let [client (seeded-client) query {:subject (contract/->user "user-1") diff --git a/modules/eacl/src/eacl/engine/indexed.cljc b/modules/eacl/src/eacl/engine/indexed.cljc index d72c2877b..0f09ad4ec 100644 --- a/modules/eacl/src/eacl/engine/indexed.cljc +++ b/modules/eacl/src/eacl/engine/indexed.cljc @@ -633,10 +633,11 @@ items (doall (map #(spice-object result-type %) limited-results)) last-id (:id (last items))] {:data items - ;; The legacy limit/cursor API signals exhaustion by returning the input - ;; cursor unchanged for an empty page. Preserve that contract while - ;; carrying v7.3 frontier state on every non-empty page. - :cursor (if (and cursor (empty? items)) + ;; The legacy limit/cursor API signals exhaustion with no cursor on an + ;; empty first page, or by returning the input cursor unchanged on a later + ;; empty page. Preserve that contract while carrying v7.3 frontier state + ;; on every non-empty page. + :cursor (if (empty? items) cursor (assoc (build-v2-cursor cursor last-id @@ -665,7 +666,7 @@ last-id (last counted)] {:count (count counted) :limit limit - :cursor (if (and cursor (empty? counted)) + :cursor (if (empty? counted) cursor (assoc (build-v2-cursor cursor last-id From bd00c8364ac6757575b43156cd528a89214ce2cb Mon Sep 17 00:00:00 2001 From: Christian Weilbach Date: Thu, 30 Jul 2026 00:23:30 -0700 Subject: [PATCH 08/13] feat(datahike): scaffold the eacl-datahike backend module MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Sets up `modules/eacl-datahike` against the modular SPI: module deps, root deps wiring (paths, dev/test/nrepl extra-paths, a :build-eacl-datahike alias), the shared-contract test, and PORTING.md. The three source files (core/impl/schema) are still to be ported from `modules/eacl-datascript`. DataScript is the template rather than Datomic, and that is the substantive finding here: both DataScript and Datahike reject a PARTIAL tuple as an `:avet` seek bound, where Datomic accepts one as a lower bound. Measured on datahike main in BOTH `:attribute-refs?` modes: seek [:room :owner] → [:kb :reader :party] bound ignored seek [:room :owner nil] → [:room :owner :party] correct seek [:room :owner :party] → [:room :owner :party] correct So the DataScript adapter's nil-padding is the correct approach on datahike too — and it is O(log n), not a workaround. An earlier attempt here treated the partial bound as a datahike compatibility bug and emulated Datomic by scanning the attribute segment; that was wrong on both counts. Requires replikativ/datahike#921 (composite `:db/tupleAttrs` were silently never derived, and tuple validation silently skipped, under `:attribute-refs?`). EACL's v7 schema is built on composite tuples, so before that fix every relation and permission tuple was absent and every permission denied. Merged to datahike main, not yet tagged, hence the :local/root — swap for an :mvn/version once released. The contract test is the definition of done: it runs the same `eacl.contract-support` suite as the DataScript backend, so the two are held to one definition rather than to tests that drifted apart. --- deps.edn | 28 +++++-- modules/eacl-datahike/PORTING.md | 75 +++++++++++++++++++ modules/eacl-datahike/deps.edn | 14 ++++ .../test/eacl/datahike/contract_test.clj | 28 +++++++ 4 files changed, 138 insertions(+), 7 deletions(-) create mode 100644 modules/eacl-datahike/PORTING.md create mode 100644 modules/eacl-datahike/deps.edn create mode 100644 modules/eacl-datahike/test/eacl/datahike/contract_test.clj diff --git a/deps.edn b/deps.edn index a0f904e52..59e6b805f 100644 --- a/deps.edn +++ b/deps.edn @@ -1,53 +1,67 @@ {:paths ["modules/eacl/src" "modules/eacl-datomic/src" "modules/eacl-datascript/src" + "modules/eacl-datahike/src" "resources"] :deps {org.clojure/clojure {:mvn/version "1.12.0-alpha5"} com.rpl/specter {:mvn/version "1.1.4"} metosin/malli {:mvn/version "0.19.1"} com.datomic/peer {:mvn/version "1.0.6733"} datascript/datascript {:mvn/version "1.7.8"} + ;; needs replikativ/datahike#921 (composite tuples under :attribute-refs?), + ;; merged to main but not yet tagged — switch to an :mvn/version once released + org.replikativ/datahike {:local/root "../datahike"} org.clojure/core.cache {:mvn/version "1.1.234"} instaparse/instaparse {:mvn/version "1.5.0"} org.clojure/tools.logging {:mvn/version "1.3.0"}} :aliases {:dev {:extra-paths ["modules/eacl/test" "modules/eacl-datomic/test" - "modules/eacl-datascript/test"]} + "modules/eacl-datascript/test" + "modules/eacl-datahike/test"]} :build-eacl {:extra-paths ["modules/eacl"] :ns-default build :extra-deps {io.github.clojure/tools.build {:mvn/version "0.10.8"}}} :build-eacl-datomic {:extra-paths ["modules/eacl-datomic"] :ns-default build :extra-deps {io.github.clojure/tools.build {:mvn/version "0.10.8"}}} + :build-eacl-datahike {:extra-paths ["modules/eacl-datahike"] + :ns-default build + :extra-deps {io.github.clojure/tools.build {:mvn/version "0.10.8"}}} :build-eacl-datascript {:extra-paths ["modules/eacl-datascript"] :ns-default build :extra-deps {io.github.clojure/tools.build {:mvn/version "0.10.8"}}} :cljs-test {:extra-paths ["modules/eacl/test" - "modules/eacl-datascript/test"] + "modules/eacl-datascript/test" + "modules/eacl-datahike/test"] :extra-deps {org.clojure/clojurescript {:mvn/version "1.12.42"}}} :datascript-cljs-test {:extra-paths ["modules/eacl/test" - "modules/eacl-datascript/test"] + "modules/eacl-datascript/test" + "modules/eacl-datahike/test"] :extra-deps {org.clojure/clojurescript {:mvn/version "1.12.42"}} :main-opts ["-m" "cljs.main" "-re" "node" "-m" "eacl.datascript.cljs-test-runner"]} :test {:extra-paths ["modules/eacl/test" "modules/eacl-datomic/test" - "modules/eacl-datascript/test"] + "modules/eacl-datascript/test" + "modules/eacl-datahike/test"] :extra-deps {io.github.cognitect-labs/test-runner {:git/tag "v0.5.1" :git/sha "dfb30dd"} criterium/criterium {:mvn/version "0.4.6"}} :main-opts ["-m" "cognitect.test-runner" "-d" "modules/eacl/test" "-d" "modules/eacl-datomic/test" - "-d" "modules/eacl-datascript/test"] + "-d" "modules/eacl-datascript/test" + "modules/eacl-datahike/test"] :exec-fn cognitect.test-runner.api/test ;; scan module test dirs only - the legacy top-level test/ tree ;; is retained for history but is not on this branch's classpath. :exec-args {:dirs ["modules/eacl/test" "modules/eacl-datomic/test" - "modules/eacl-datascript/test"]}} + "modules/eacl-datascript/test" + "modules/eacl-datahike/test"]}} :nrepl {:extra-paths ["modules/eacl/test" "modules/eacl-datomic/test" - "modules/eacl-datascript/test"] + "modules/eacl-datascript/test" + "modules/eacl-datahike/test"] :extra-deps {nrepl/nrepl {:mvn/version "1.3.1"}} :main-opts ["-m" "nrepl.cmdline"]}}} diff --git a/modules/eacl-datahike/PORTING.md b/modules/eacl-datahike/PORTING.md new file mode 100644 index 000000000..60629d1f8 --- /dev/null +++ b/modules/eacl-datahike/PORTING.md @@ -0,0 +1,75 @@ +# Porting the DataScript backend to Datahike + +The three source files are a near-mechanical port of `modules/eacl-datascript` +(425 + 505 + 224 lines: `core.cljc`, `impl.cljc`, `schema.cljc`). DataScript is +the right template rather than Datomic, because both DataScript and Datahike +diverge from Datomic in the *same* places — see "Tuple seek bounds" below. + +The target is `test/eacl/datahike/contract_test.clj`, which runs the shared +`eacl.contract-support` suite. A backend is done when that passes. + +## What actually differs from the DataScript source + +| | DataScript | Datahike | +|---|---|---| +| `datoms` / `seek-datoms` / `rseek-datoms` | positional: `(ds/seek-datoms db :avet a v)` | option MAP: `(dh/seek-datoms db {:index :avet :components [a v]})` | +| `index-range` | — | `(dh/index-range db {:attrid a :start s :end e})` | +| `transact` | `ds/transact!`, returns report | `dh/transact`, returns report (NOT a future — no `@`) | +| `entid` | `ds/entid` | **absent** — use `(:db/id (dh/entity db ident))` | +| conn creation | `(ds/create-conn schema)` | `(dh/create-database cfg)` then `(dh/connect cfg)` | +| db value | `@conn` | `(dh/db conn)` or `@conn` | + +Datahike additionally needs a real config. Use: + +```clojure +{:store {:backend :memory :id (random-uuid)} + :schema-flexibility :write ; required: tuple attrs must be declared + :keep-history? false} +``` + +## Tuple seek bounds — the one non-obvious thing + +MEASURED on datahike main (with #921), in BOTH `:attribute-refs?` modes: + +```clojure +seek [:room :owner] → [:kb :reader :party] ; bound IGNORED +seek [:room :owner nil] → [:room :owner :party] ; correct +seek [:room :owner :party]→ [:room :owner :party] ; correct +``` + +So a PARTIAL tuple is not a valid seek bound — identical to DataScript, whose +adapter comments "DataScript sorts vectors by LENGTH FIRST". Datomic is the +outlier here, and `modules/eacl-datomic` relies on Datomic's behaviour. + +**Therefore: keep the DataScript approach verbatim** — pad to full tuple arity +with `nil` (`nil` sorts lowest) and then `take-while` on the prefix. Do NOT try +to emulate Datomic's partial-tuple bound, and do not work around it by scanning +the whole attribute segment: padding is correct AND O(log n). + +## Attribute representation — why this module needs no `:a` handling + +Datahike reports a datom's `:a` as the attribute KEYWORD by default, and as a +numeric ref under `:attribute-refs? true` (Datomic's representation). The engine +above the SPI never sees `:a`, so this is purely internal here — but be +consistent within the module: compare attributes with `=`, never `==`, and +resolve through `attr-ident`-style lookups before consulting schema/rschema. + +A composite tuple attribute under `:attribute-refs?` requires datahike ≥ the +#921 fix. Before it, tuples were silently never derived and never validated. + +## SPI surface to implement + +`eacl.backend.spi` is six fns supplied as a map (see +`modules/eacl/src/eacl/backend/spi.cljc`): + +`cache-stamp` · `relation-defs` · `permission-defs` · `subject->resources` · +`resource->subjects` · `direct-match?` + +None of them mention datoms, seeks, or attribute ids — those are all private to +this module. + +## Wiring + +Add `"modules/eacl-datahike/src"` to the root `deps.edn` `:paths`, the test dir +to `:dev`/`:test`/`:nrepl` `:extra-paths`, and `org.replikativ/datahike` to +`:deps`. A `:build-eacl-datahike` alias mirrors the other modules. diff --git a/modules/eacl-datahike/deps.edn b/modules/eacl-datahike/deps.edn new file mode 100644 index 000000000..8584f18dc --- /dev/null +++ b/modules/eacl-datahike/deps.edn @@ -0,0 +1,14 @@ +{:paths ["src" "resources"] + :deps {org.clojure/clojure {:mvn/version "1.12.0-alpha5"} + cloudafrica/eacl {:local/root "../eacl"} + ;; Needs the composite-tuple fix (replikativ/datahike#921): without it EVERY + ;; relation and permission tuple silently fails to derive under + ;; :attribute-refs?, so every permission denies. Merged to datahike main but + ;; not yet tagged — switch to an :mvn/version once released. + org.replikativ/datahike {:local/root "../../../datahike"} + org.clojure/tools.logging {:mvn/version "1.3.0"}} + :aliases {:test {:extra-paths ["test"] + :extra-deps {io.github.cognitect-labs/test-runner {:git/tag "v0.5.1" :git/sha "dfb30dd"}}} + :nrepl {:extra-paths ["test"] + :extra-deps {nrepl/nrepl {:mvn/version "1.3.1"}} + :main-opts ["-m" "nrepl.cmdline"]}}} diff --git a/modules/eacl-datahike/test/eacl/datahike/contract_test.clj b/modules/eacl-datahike/test/eacl/datahike/contract_test.clj new file mode 100644 index 000000000..65e082c40 --- /dev/null +++ b/modules/eacl-datahike/test/eacl/datahike/contract_test.clj @@ -0,0 +1,28 @@ +(ns eacl.datahike.contract-test + "The shared backend contract, on Datahike. A backend is finished when this + passes — it is the same suite `eacl.datascript.contract-test` runs, so the + two backends are held to one definition rather than to separate tests that + drifted." + (:require [clojure.test :refer [deftest]] + [datahike.api :as d] + [eacl.contract-support :as contract] + [eacl.core :as eacl] + [eacl.datahike.core :as datahike])) + +(defn- seed-objects! + "The contract's objects, addressed by `:eacl/id`. Negative `:db/id`s are + tempids, as in the DataScript contract test." + [conn] + (d/transact conn + (map-indexed (fn [idx {:keys [id]}] + {:db/id (- (inc idx)) + :eacl/id id}) + contract/smoke-objects))) + +(deftest datahike-contract-test + (let [conn (datahike/create-conn) + client (datahike/make-client conn {})] + (eacl/write-schema! client contract/smoke-schema) + (seed-objects! conn) + (eacl/create-relationships! client contract/smoke-relationships) + (contract/assert-seeded-contracts! client))) From dad397b08f9e3f744bcd289a50da8e9092ed0d46 Mon Sep 17 00:00:00 2001 From: Christian Weilbach Date: Thu, 30 Jul 2026 01:45:02 -0700 Subject: [PATCH 09/13] feat(datahike): a datahike backend, held to the shared contract MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Implements the six-fn backend SPI over datahike, ported from modules/eacl-datascript. DataScript rather than Datomic is the template because DataScript and datahike order tuple index bounds the same way. eacl.datahike.contract-test runs the shared eacl.contract-support suite — the same 23 assertions the DataScript backend answers — TWICE, once per attribute representation. Datahike reports a datom's :a as the attribute keyword by default and as a numeric ref under :attribute-refs? (Datomic's representation), and the second mode is where things break quietly, in three ways that all had to be handled: - composite tuples need datahike >= 0.8.1759 (replikativ/datahike#921). Before it they were silently never derived; since the tuples ARE the v7 engine, every permission check denied. - index-range's :attrid is the one accessor that rejects the attribute keyword under :attribute-refs?. It raises, so this one was loud. - comparing a datom's :a against a keyword set matches nothing, which for the cache-eviction listener fails OPEN: can? keeps answering from pre-change permission paths and grants what the schema just revoked. Adds eacl.datahike.db as a fourth namespace, so every divergence from the DataScript source (entid, attribute representation, the index accessors) sits in one file and the rest reads like its template. Adds eacl.datahike.backend-test for the paths the shared contract cannot reach. Worth stating plainly: the contract goes through make-client, which serves relation definitions from a prebuilt catalog, so it never exercises the tuple seek — deleting the nil padding leaves the contract suite green. Both mechanisms were verified by breaking them: no padding fails 12 assertions in both modes, a raw :a comparison fails exactly 1, only under :attribute-refs?. Module is JVM-only: datahike's CLJS API is async, the SPI is synchronous. Full suite: 61 tests, 951 assertions, 0 failures (all four modules). --- .gitignore | 1 + deps.edn | 20 +- modules/eacl-datahike/PORTING.md | 132 +++-- .../eacl-datahike/src/eacl/datahike/core.clj | 439 ++++++++++++++++ .../eacl-datahike/src/eacl/datahike/db.clj | 96 ++++ .../eacl-datahike/src/eacl/datahike/impl.clj | 481 ++++++++++++++++++ .../src/eacl/datahike/schema.clj | 319 ++++++++++++ .../test/eacl/datahike/backend_test.clj | 148 ++++++ .../test/eacl/datahike/contract_test.clj | 32 +- 9 files changed, 1603 insertions(+), 65 deletions(-) create mode 100644 modules/eacl-datahike/src/eacl/datahike/core.clj create mode 100644 modules/eacl-datahike/src/eacl/datahike/db.clj create mode 100644 modules/eacl-datahike/src/eacl/datahike/impl.clj create mode 100644 modules/eacl-datahike/src/eacl/datahike/schema.clj create mode 100644 modules/eacl-datahike/test/eacl/datahike/backend_test.clj diff --git a/.gitignore b/.gitignore index 08fd8be02..5293767d6 100644 --- a/.gitignore +++ b/.gitignore @@ -3,3 +3,4 @@ .cpcache/ /spicedb target/ +.nrepl-port diff --git a/deps.edn b/deps.edn index 59e6b805f..0af6c124b 100644 --- a/deps.edn +++ b/deps.edn @@ -8,9 +8,9 @@ metosin/malli {:mvn/version "0.19.1"} com.datomic/peer {:mvn/version "1.0.6733"} datascript/datascript {:mvn/version "1.7.8"} - ;; needs replikativ/datahike#921 (composite tuples under :attribute-refs?), - ;; merged to main but not yet tagged — switch to an :mvn/version once released - org.replikativ/datahike {:local/root "../datahike"} + ;; 0.8.1759 is the first release carrying replikativ/datahike#921 + ;; (composite tuples derived + validated under :attribute-refs?) + org.replikativ/datahike {:mvn/version "0.8.1759"} org.clojure/core.cache {:mvn/version "1.1.234"} instaparse/instaparse {:mvn/version "1.5.0"} org.clojure/tools.logging {:mvn/version "1.3.0"}} @@ -31,12 +31,10 @@ :ns-default build :extra-deps {io.github.clojure/tools.build {:mvn/version "0.10.8"}}} :cljs-test {:extra-paths ["modules/eacl/test" - "modules/eacl-datascript/test" - "modules/eacl-datahike/test"] + "modules/eacl-datascript/test"] :extra-deps {org.clojure/clojurescript {:mvn/version "1.12.42"}}} :datascript-cljs-test {:extra-paths ["modules/eacl/test" - "modules/eacl-datascript/test" - "modules/eacl-datahike/test"] + "modules/eacl-datascript/test"] :extra-deps {org.clojure/clojurescript {:mvn/version "1.12.42"}} :main-opts ["-m" "cljs.main" "-re" "node" @@ -44,24 +42,24 @@ :test {:extra-paths ["modules/eacl/test" "modules/eacl-datomic/test" "modules/eacl-datascript/test" - "modules/eacl-datahike/test"] + "modules/eacl-datahike/test"] :extra-deps {io.github.cognitect-labs/test-runner {:git/tag "v0.5.1" :git/sha "dfb30dd"} criterium/criterium {:mvn/version "0.4.6"}} :main-opts ["-m" "cognitect.test-runner" "-d" "modules/eacl/test" "-d" "modules/eacl-datomic/test" "-d" "modules/eacl-datascript/test" - "modules/eacl-datahike/test"] + "-d" "modules/eacl-datahike/test"] :exec-fn cognitect.test-runner.api/test ;; scan module test dirs only - the legacy top-level test/ tree ;; is retained for history but is not on this branch's classpath. :exec-args {:dirs ["modules/eacl/test" "modules/eacl-datomic/test" "modules/eacl-datascript/test" - "modules/eacl-datahike/test"]}} + "modules/eacl-datahike/test"]}} :nrepl {:extra-paths ["modules/eacl/test" "modules/eacl-datomic/test" "modules/eacl-datascript/test" - "modules/eacl-datahike/test"] + "modules/eacl-datahike/test"] :extra-deps {nrepl/nrepl {:mvn/version "1.3.1"}} :main-opts ["-m" "nrepl.cmdline"]}}} diff --git a/modules/eacl-datahike/PORTING.md b/modules/eacl-datahike/PORTING.md index 60629d1f8..678a09324 100644 --- a/modules/eacl-datahike/PORTING.md +++ b/modules/eacl-datahike/PORTING.md @@ -1,63 +1,109 @@ -# Porting the DataScript backend to Datahike +# The Datahike backend -The three source files are a near-mechanical port of `modules/eacl-datascript` -(425 + 505 + 224 lines: `core.cljc`, `impl.cljc`, `schema.cljc`). DataScript is -the right template rather than Datomic, because both DataScript and Datahike -diverge from Datomic in the *same* places — see "Tuple seek bounds" below. +A port of `modules/eacl-datascript`. DataScript was the right template rather +than Datomic, because DataScript and Datahike diverge from Datomic in the *same* +place — see "Tuple seek bounds" below. -The target is `test/eacl/datahike/contract_test.clj`, which runs the shared -`eacl.contract-support` suite. A backend is done when that passes. +Status: `eacl.datahike.contract-test` runs the shared `eacl.contract-support` +suite (the same one the DataScript backend runs, 23 assertions) **twice**, once +per attribute representation, and passes. `eacl.datahike.backend-test` covers +the datahike-specific paths the shared contract does not reach. -## What actually differs from the DataScript source +The module is **JVM-only** (`.clj`, not `.cljc`): datahike's ClojureScript API is +asynchronous and the backend SPI is synchronous. + +## Layout + +Four namespaces, where DataScript has three. `eacl.datahike.db` holds the +adapter primitives — `entid`, attribute representation, and the three index +accessors — so that everything above it reads like the DataScript source and +every datahike divergence lives in one file: + +| | | +|---|---| +| `db.clj` | adapter primitives (no eacl concepts) | +| `schema.clj` | attribute declarations, `create-conn`, `write-schema!` | +| `impl.clj` | the SPI implementation and relationship scans | +| `core.clj` | `IAuthorization`, `make-client`, cursor coercion | + +## What differs from the DataScript source | | DataScript | Datahike | |---|---|---| -| `datoms` / `seek-datoms` / `rseek-datoms` | positional: `(ds/seek-datoms db :avet a v)` | option MAP: `(dh/seek-datoms db {:index :avet :components [a v]})` | -| `index-range` | — | `(dh/index-range db {:attrid a :start s :end e})` | -| `transact` | `ds/transact!`, returns report | `dh/transact`, returns report (NOT a future — no `@`) | -| `entid` | `ds/entid` | **absent** — use `(:db/id (dh/entity db ident))` | -| conn creation | `(ds/create-conn schema)` | `(dh/create-database cfg)` then `(dh/connect cfg)` | -| db value | `@conn` | `(dh/db conn)` or `@conn` | +| `datoms` / `seek-datoms` | positional: `(ds/seek-datoms db :avet a v)` | option MAP: `(d/seek-datoms db {:index :avet :components [a v]})` | +| `index-range` | positional | `(d/index-range db {:attrid a :start s :end e})` | +| `transact` | `ds/transact!` | `d/transact` — a report, not a future, so no `@` | +| `entid` | `ds/entid` | **absent** — `db/entid`, via `d/entity` | +| `listen` | `ds/listen!` | `d/listen` | +| conn creation | `(ds/create-conn schema)` | `create-database` + `connect`, with a config | +| schema | map of attribute to options | transaction data; `:write` flexibility needs `:db/valueType` and `:db/cardinality` on every attribute | +| `extra-schema` | DataScript schema map | datahike transaction data — the two are NOT interconvertible, since a DataScript schema map carries no value types | -Datahike additionally needs a real config. Use: +`read-relations` / `read-permissions` read the index rather than running the +DataScript version's `q` with a pull expression: the index is the engine's own +view of the schema, so a relation invisible there is invisible to permission +evaluation too, and it sidesteps datahike's query planner entirely. -```clojure -{:store {:backend :memory :id (random-uuid)} - :schema-flexibility :write ; required: tuple attrs must be declared - :keep-history? false} -``` +## Attribute representation — two modes, and they are not interchangeable + +Datahike reports a datom's `:a` as the attribute KEYWORD by default and as a +numeric ref under `:attribute-refs? true` (Datomic's representation). This is a +creation-time, one-way choice per database. Both modes are supported and both +are tested; three consequences are load-bearing. -## Tuple seek bounds — the one non-obvious thing +1. A composite tuple attribute under `:attribute-refs?` needs datahike + **>= 0.8.1759** (replikativ/datahike#921). Before that fix the tuples were + silently never derived and never validated, and since the tuples ARE the v7 + engine, every permission check denied. -MEASURED on datahike main (with #921), in BOTH `:attribute-refs?` modes: +2. `index-range`'s `:attrid` is the one accessor that does **not** accept the + attribute keyword in both modes: under `:attribute-refs?` it demands the + numeric ref and raises. `db/avet-range` resolves it via `db/attr-repr`. + (`datoms` and `seek-datoms` take the keyword in either mode.) + +3. Anything comparing a datom's `:a` against a set of keywords matches nothing + under `:attribute-refs?`. In this module that is `core/schema-transaction?`, + the tx listener that evicts cached permission paths. Left unresolved it + fails **OPEN** — `can?` keeps answering from pre-change permission paths and + grants what the schema has just revoked. `db/attr-ident` resolves it. + +MEASURED, both modes: `(:attribute-refs? (:config db))` is the reliable flag. + +## Tuple seek bounds — the one non-obvious ordering fact + +MEASURED on datahike 0.8.1759, in BOTH modes: ```clojure -seek [:room :owner] → [:kb :reader :party] ; bound IGNORED -seek [:room :owner nil] → [:room :owner :party] ; correct -seek [:room :owner :party]→ [:room :owner :party] ; correct +seek [:room :owner] → [:kb :reader :party] ; bound IGNORED +seek [:room :owner nil] → [:room :owner :party] ; correct +seek [:room :owner :party] → [:room :owner :party] ; correct ``` -So a PARTIAL tuple is not a valid seek bound — identical to DataScript, whose +A PARTIAL tuple is not a valid seek bound — identical to DataScript, whose adapter comments "DataScript sorts vectors by LENGTH FIRST". Datomic is the -outlier here, and `modules/eacl-datomic` relies on Datomic's behaviour. +outlier, and `modules/eacl-datomic` relies on Datomic's behaviour. -**Therefore: keep the DataScript approach verbatim** — pad to full tuple arity -with `nil` (`nil` sorts lowest) and then `take-while` on the prefix. Do NOT try -to emulate Datomic's partial-tuple bound, and do not work around it by scanning -the whole attribute segment: padding is correct AND O(log n). +So `db/seek-tuple-prefix` pads to full tuple arity with `nil` (`nil` sorts +lowest) and then takes the matching prefix. Padding is both correct AND +O(log n) — do not replace it with a scan of the whole attribute segment. -## Attribute representation — why this module needs no `:a` handling +`seek-datoms` also runs off the end of the attribute into the next one, so the +`take-while` guards on `:a` as well as on the value. -Datahike reports a datom's `:a` as the attribute KEYWORD by default, and as a -numeric ref under `:attribute-refs? true` (Datomic's representation). The engine -above the SPI never sees `:a`, so this is purely internal here — but be -consistent within the module: compare attributes with `=`, never `==`, and -resolve through `attr-ident`-style lookups before consulting schema/rschema. +## A coverage trap worth knowing about -A composite tuple attribute under `:attribute-refs?` requires datahike ≥ the -#921 fix. Before it, tuples were silently never derived and never validated. +The shared contract goes through `make-client`, which serves relation +definitions from a prebuilt schema catalog — a full index scan. So **the +contract suite never exercises the tuple seek at all**: removing the nil +padding entirely leaves it green. The seek is reached only by the bare-db path +(`impl/can?` with no options) and by the relation-retraction guard, which is +what `backend-test` tests directly. -## SPI surface to implement +Both mechanisms above were verified non-vacuously by breaking them: +removing the padding fails 12 assertions in both modes; comparing `:a` raw +fails exactly 1, only under `:attribute-refs?`. + +## SPI surface `eacl.backend.spi` is six fns supplied as a map (see `modules/eacl/src/eacl/backend/spi.cljc`): @@ -67,9 +113,3 @@ A composite tuple attribute under `:attribute-refs?` requires datahike ≥ the None of them mention datoms, seeks, or attribute ids — those are all private to this module. - -## Wiring - -Add `"modules/eacl-datahike/src"` to the root `deps.edn` `:paths`, the test dir -to `:dev`/`:test`/`:nrepl` `:extra-paths`, and `org.replikativ/datahike` to -`:deps`. A `:build-eacl-datahike` alias mirrors the other modules. diff --git a/modules/eacl-datahike/src/eacl/datahike/core.clj b/modules/eacl-datahike/src/eacl/datahike/core.clj new file mode 100644 index 000000000..23eaffa34 --- /dev/null +++ b/modules/eacl-datahike/src/eacl/datahike/core.clj @@ -0,0 +1,439 @@ +(ns eacl.datahike.core + (:require [com.rpl.specter :as S] + [datahike.api :as d] + [eacl.core :as eacl :refer [IAuthorization + spice-object + ->Relationship + ->RelationshipUpdate + map->Relationship]] + [eacl.cursor :as cursor] + [eacl.datahike.db :as ddb] + [eacl.datahike.impl :as impl] + [eacl.datahike.schema :as schema] + [eacl.spicedb.consistency :as consistency])) + +(def cursor->token cursor/cursor->token) +(def token->cursor cursor/token->cursor) + +(defn default-internal-cursor->spice + [db {:keys [entid->object-id]} cursor] + (when cursor + (cond + (= 3 (:v cursor)) + (cond-> cursor + (:subject cursor) (update :subject #(entid->object-id db %)) + (:resource cursor) (update :resource #(entid->object-id db %))) + + (= 2 (:v cursor)) + (cond-> cursor + (:e cursor) (update :e #(entid->object-id db %)) + (:p cursor) (update :p + (fn [p] + (into {} + (map (fn [[k v]] [k (entid->object-id db v)])) + p)))) + :else + (cond + (:resource cursor) (S/transform [:resource :id] #(entid->object-id db %) cursor) + (:subject cursor) (S/transform [:subject :id] #(entid->object-id db %) cursor))))) + +(defn default-spice-cursor->internal + [db {:keys [object-id->entid]} cursor] + (when cursor + (cond + (= 3 (:v cursor)) + (cond-> cursor + (:subject cursor) (update :subject #(object-id->entid db %)) + (:resource cursor) (update :resource #(object-id->entid db %))) + + (= 2 (:v cursor)) + (cond-> cursor + (:e cursor) (update :e #(object-id->entid db %)) + (:p cursor) (update :p + (fn [p] + (into {} + (map (fn [[k v]] [k (object-id->entid db v)])) + p)))) + :else + (cond + (:resource cursor) (S/transform [:resource :id] #(object-id->entid db %) cursor) + (:subject cursor) (S/transform [:subject :id] #(object-id->entid db %) cursor))))) + +(defn object->spice + [db {:keys [entid->object-id]} object] + (update object :id #(entid->object-id db %))) + +(defn relationship->spice + [db opts {:keys [subject relation resource]}] + (map->Relationship + {:subject (object->spice db opts subject) + :relation relation + :resource (object->spice db opts resource)})) + +(defn datahike-read-relationships + [db + {:as opts + :keys [object-id->entid + internal-cursor->spice + spice-cursor->internal]} + filters] + (let [subject-id (:subject/id filters) + resource-id (:resource/id filters) + subject-eid (when subject-id (object-id->entid db subject-id)) + resource-eid (when resource-id (object-id->entid db resource-id)) + missing-id? (or (and subject-id (nil? subject-eid)) + (and resource-id (nil? resource-eid)))] + (if missing-id? + {:data [] :cursor nil} + (let [filters' (cond-> filters + subject-id (assoc :subject/id subject-eid) + resource-id (assoc :resource/id resource-eid)) + filters'' (S/transform [:cursor] + (fn [token-or-cursor] + (some->> (token->cursor token-or-cursor opts) + (spice-cursor->internal db opts))) + filters') + result (impl/read-relationships db filters'')] + (-> result + ((fn [page] + (S/transform [:data S/ALL] + #(relationship->spice db opts %) + page))) + ((fn [page] + (S/transform [:cursor] + (fn [internal-cursor] + (some-> (internal-cursor->spice db opts internal-cursor) + (cursor->token opts))) + page)))))))) + +(defn spice-relationship->internal + [db {:keys [spice-object->internal]} {:keys [subject relation resource]}] + {:subject (spice-object->internal db subject) + :relation relation + :resource (spice-object->internal db resource)}) + +(defn datahike-write-relationships! + [conn opts updates] + (let [db (d/db conn) + tx-stamp (:tx-stamp opts) + tx-data (->> updates + (S/transform [S/ALL :relationship] + #(spice-relationship->internal db opts %)) + (mapcat #(impl/tx-update-relationship db %)) + (remove nil?) + (vec))] + (when (seq tx-data) + (d/transact conn tx-data)) + {:zed/token (str @tx-stamp)})) + +(defn- relationship-seq + [relationships] + (if (map? relationships) + (:data relationships) + relationships)) + +(defn datahike-can? + [db {:keys [object->entid] :as opts} subject permission resource consistency] + (when-not (= consistency/fully-consistent consistency) + (throw (ex-info "EACL only supports consistency/fully-consistent at this time." + {:type :eacl/unsupported-consistency + :consistency consistency}))) + (let [subject-type (:type subject) + subject-id (object->entid db subject) + resource-type (:type resource) + resource-id (object->entid db resource)] + (if-not (and subject-id resource-id) + false + (impl/can? db + opts + (spice-object subject-type subject-id) + permission + (spice-object resource-type resource-id))))) + +(defn datahike-lookup-resources + [db + {:as opts + :keys [spice-object->internal + entid->object-id + object-id->lookup-ref + internal-cursor->spice + spice-cursor->internal]} + {:as query :keys [subject]}] + (let [internal-subject (spice-object->internal db subject)] + (if (nil? (:id internal-subject)) + ;; Unknown subjects match nothing (SpiceDB-consistent; can? is false). + {:data [] :cursor nil} + (->> query + (S/setval [:subject] internal-subject) + (S/transform [:cursor] + (fn [token-or-cursor] + (some->> (token->cursor token-or-cursor opts) + (spice-cursor->internal db opts)))) + (impl/lookup-resources db opts) + (S/transform [:data S/ALL] + (fn [{:keys [type id]}] + (spice-object type (entid->object-id db id)))) + (S/transform [:cursor] + (fn [internal-cursor] + (some-> (internal-cursor->spice db opts internal-cursor) + (cursor->token opts)))))))) + +(defn datahike-count-resources + [db + {:as opts + :keys [spice-object->internal + spice-cursor->internal + internal-cursor->spice]} + {:as query :keys [subject]}] + (let [subject-ent (spice-object->internal db subject)] + (->> query + (S/setval [:subject] subject-ent) + (S/transform [:cursor] + (fn [token-or-cursor] + (some->> (token->cursor token-or-cursor opts) + (spice-cursor->internal db opts)))) + (impl/count-resources db opts) + (S/transform [:cursor] + (fn [internal-cursor] + (some-> (internal-cursor->spice db opts internal-cursor) + (cursor->token opts))))))) + +(defn datahike-lookup-subjects + [db + {:as opts + :keys [entid->object-id + spice-object->internal + spice-cursor->internal + internal-cursor->spice]} + query] + (->> query + (S/transform [:resource] #(spice-object->internal db %)) + (S/transform [:cursor] + (fn [token-or-cursor] + (some->> (token->cursor token-or-cursor opts) + (spice-cursor->internal db opts)))) + (impl/lookup-subjects db opts) + (S/transform [:data S/ALL] + (fn [{:keys [type id]}] + (spice-object type (entid->object-id db id)))) + (S/transform [:cursor] + (fn [internal-cursor] + (some-> (internal-cursor->spice db opts internal-cursor) + (cursor->token opts)))))) + +(defn datahike-count-subjects + [db + {:as opts + :keys [spice-object->internal + spice-cursor->internal + internal-cursor->spice]} + query] + (->> query + (S/transform [:resource] #(spice-object->internal db %)) + (S/transform [:cursor] + (fn [token-or-cursor] + (some->> (token->cursor token-or-cursor opts) + (spice-cursor->internal db opts)))) + (impl/count-subjects db opts) + (S/transform [:cursor] + (fn [internal-cursor] + (some-> (internal-cursor->spice db opts internal-cursor) + (cursor->token opts)))))) + +(defrecord DatahikeAuthorization [conn opts] + IAuthorization + (can? [_ subject permission resource] + (datahike-can? (d/db conn) opts subject permission resource consistency/fully-consistent)) + (can? [_ subject permission resource consistency] + (datahike-can? (d/db conn) opts subject permission resource consistency)) + (can? [_ {:keys [subject permission resource consistency]}] + (datahike-can? (d/db conn) opts subject permission resource + (or consistency consistency/fully-consistent))) + + (read-schema [_] + (schema/read-schema (d/db conn))) + (write-schema! [_ schema-string] + (schema/write-schema! conn schema-string)) + + (read-relationships [_ filters] + (datahike-read-relationships (d/db conn) opts filters)) + (write-relationships! [_ updates] + (datahike-write-relationships! conn opts updates)) + (write-relationship! [_ operation subject relation resource] + (datahike-write-relationships! conn opts + [(->RelationshipUpdate operation + (->Relationship subject relation resource))])) + (write-relationship! [_ {:as demand :keys [operation subject relation resource]}] + (datahike-write-relationships! conn opts + [(->RelationshipUpdate operation + (->Relationship subject relation resource))])) + (create-relationships! [_ relationships] + (datahike-write-relationships! conn opts + (for [rel relationships] + (->RelationshipUpdate :create rel)))) + (create-relationship! [_ relationship] + (datahike-write-relationships! conn opts + [(->RelationshipUpdate :create relationship)])) + (create-relationship! [_ subject relation resource] + (datahike-write-relationships! conn opts + [(->RelationshipUpdate :create (->Relationship subject relation resource))])) + (delete-relationships! [_ relationships] + (datahike-write-relationships! conn opts + (for [rel (relationship-seq relationships)] + (->RelationshipUpdate :delete rel)))) + (delete-relationship! [_ {:as relationship :keys [subject relation resource]}] + (datahike-write-relationships! conn opts + [(->RelationshipUpdate :delete + (->Relationship subject relation resource))])) + (delete-relationship! [_ subject relation resource] + (datahike-write-relationships! conn opts + [(->RelationshipUpdate :delete + (->Relationship subject relation resource))])) + + (lookup-resources [_ query] + (datahike-lookup-resources (d/db conn) opts query)) + (count-resources [_ query] + (datahike-count-resources (d/db conn) opts query)) + (lookup-subjects [_ query] + (datahike-lookup-subjects (d/db conn) opts query)) + (count-subjects [_ query] + (datahike-count-subjects (d/db conn) opts query)) + + (expand-permission-tree [_ _] + (throw (ex-info "expand-permission-tree is not implemented yet." + {:type :eacl/not-implemented + :method (quote expand-permission-tree)})))) + +(defonce runtime-state-registry (atom {})) + +(defn- schema-transaction? + "Whether `tx-report` touched EACL's schema, and so invalidated the permission + paths and the schema catalog. + + The ident resolution is load-bearing, not defensive: under + `:attribute-refs? true` a datom's `:a` is a numeric ref, so comparing it + against a set of keywords matches nothing and the derived caches are never + invalidated — a schema change would keep answering from stale permission + paths. `:db-after` is used because a retraction's attribute must still + resolve." + [tx-report] + (let [db (:db-after tx-report)] + (boolean + (some (fn [{:keys [a]}] + (contains? schema/schema-change-attrs (ddb/attr-ident db a))) + (:tx-data tx-report))))) + +(defn- reset-schema-derived-state! + [state] + (swap! (:schema-stamp state) inc) + (reset! (:permission-paths-cache state) {}) + (reset! (:schema-catalog state) nil)) + +(defn ensure-runtime-state! + [conn] + (if-let [state (get @runtime-state-registry conn)] + state + (let [state {:conn-id (random-uuid) + :tx-stamp (atom 0) + :schema-stamp (atom 0) + :permission-paths-cache (atom {}) + :schema-catalog (atom nil) + :listener-key (keyword (str "eacl-stamp-" (random-uuid)))}] + (d/listen conn + (:listener-key state) + (fn [tx-report] + (swap! (:tx-stamp state) inc) + (when (schema-transaction? tx-report) + (reset-schema-derived-state! state)))) + (get (swap! runtime-state-registry + #(if (contains? % conn) % (assoc % conn state))) + conn)))) + +(defn- ensure-schema-catalog! + [state db] + (let [schema-stamp @(:schema-stamp state) + cached @(:schema-catalog state)] + (if (= schema-stamp (:schema-stamp cached)) + (:catalog cached) + (let [catalog (impl/build-schema-catalog db)] + (-> (swap! (:schema-catalog state) + (fn [entry] + (if (= schema-stamp (:schema-stamp entry)) + entry + {:schema-stamp schema-stamp + :catalog catalog}))) + :catalog))))) + +(def ^:private known-client-opt-keys + #{:entid->object-id + :entity->object-id + :object-id->lookup-ref + :internal-cursor->spice + :spice-cursor->internal + :cursor-ttl-seconds}) + +(defn make-client + "Builds an IAuthorization client over a datahike conn. + + Options (unknown keys throw :eacl/invalid-config - a silently ignored key + means silently wrong ID coercion, audit 5): + - :entid->object-id (fn [db eid] external-id) - canonical. + - :entity->object-id (fn [entity] external-id) - deprecated alias; do not combine. + - :object-id->lookup-ref (fn [external-id] lookup-ref). Default: [:eacl/id id]. + - :cursor-ttl-seconds - optional cursor token expiry; default nil (tokens never expire). + - :internal-cursor->spice / :spice-cursor->internal - advanced cursor coercion overrides." + [conn + {:as config-opts + :keys [entid->object-id + entity->object-id + object-id->lookup-ref + internal-cursor->spice + spice-cursor->internal + cursor-ttl-seconds] + :or {object-id->lookup-ref (fn [obj-id] [:eacl/id obj-id]) + internal-cursor->spice default-internal-cursor->spice + spice-cursor->internal default-spice-cursor->internal}}] + (when-let [unknown-keys (seq (remove known-client-opt-keys (keys config-opts)))] + (throw (ex-info (str "EACL Config Error: unknown make-client option(s) " (pr-str (vec unknown-keys)) + ". Known options: " (pr-str (vec (sort known-client-opt-keys))) ".") + {:type :eacl/invalid-config + :unknown-keys (vec unknown-keys) + :known-keys known-client-opt-keys}))) + (when (and entid->object-id entity->object-id) + (throw (ex-info "EACL Config Error: supply only one of :entid->object-id (canonical) or :entity->object-id (deprecated alias)." + {:type :eacl/invalid-config + :conflicting-keys [:entid->object-id :entity->object-id]}))) + (let [runtime-state (ensure-runtime-state! conn) + object-id->entid (fn [db object-id] + (ddb/entid db (object-id->lookup-ref object-id))) + entid->object-id (or entid->object-id + (when entity->object-id + (fn [db eid] (entity->object-id (d/entity db eid)))) + (fn [db eid] (:eacl/id (d/entity db eid)))) + opts {:object-id->lookup-ref object-id->lookup-ref + :cache-stamp (fn [] + [(:conn-id runtime-state) + @(:schema-stamp runtime-state)]) + :tx-stamp (:tx-stamp runtime-state) + :permission-paths-cache (:permission-paths-cache runtime-state) + :schema-catalog (fn [db] + (ensure-schema-catalog! runtime-state db)) + :entid->object-id entid->object-id + :object-id->entid object-id->entid + :cursor-ttl-seconds cursor-ttl-seconds + :object->entid (fn [db {:keys [id]}] + (object-id->entid db id)) + :internal-object->spice (fn [db {:keys [type id]}] + (spice-object type (entid->object-id db id))) + :spice-object->internal (fn [db obj] + (update obj :id #(object-id->entid db %))) + :internal-cursor->spice internal-cursor->spice + :spice-cursor->internal spice-cursor->internal}] + (->DatahikeAuthorization conn opts))) + +(defn create-conn + "A datahike connection carrying EACL's schema. See + `eacl.datahike.schema/create-conn` for the config options." + ([] (schema/create-conn)) + ([extra-schema] (schema/create-conn extra-schema)) + ([extra-schema config] (schema/create-conn extra-schema config))) diff --git a/modules/eacl-datahike/src/eacl/datahike/db.clj b/modules/eacl-datahike/src/eacl/datahike/db.clj new file mode 100644 index 000000000..351d1226a --- /dev/null +++ b/modules/eacl-datahike/src/eacl/datahike/db.clj @@ -0,0 +1,96 @@ +(ns eacl.datahike.db + "Datahike adapter primitives: the handful of places where datahike spells + something differently from DataScript. Nothing above this namespace mentions + datoms, seek bounds, or how an attribute is represented in a datom. + + This namespace is JVM-only, as is the rest of the module: datahike's + ClojureScript API is asynchronous, and the backend SPI is synchronous." + (:require [datahike.api :as d])) + +(defn entid + "`entid` as DataScript and Datomic define it: a number passes through + unchanged (an unallocated id is deliberately NOT rejected), an ident or + lookup ref resolves to its eid, and an unresolvable one is nil. + + Datahike has no public `entid`, but `d/entity` returns nil rather than + throwing for an unresolvable lookup ref, which is exactly the contract eacl + reads. Anything else throws, as in DataScript — a silently-nil id means a + permission check that denies for the wrong reason." + [db eid-or-ref] + (cond + (nil? eid-or-ref) nil + (number? eid-or-ref) eid-or-ref + (or (keyword? eid-or-ref) (sequential? eid-or-ref)) (:db/id (d/entity db eid-or-ref)) + :else (throw (ex-info (str "Expected a number, ident or lookup ref, got " (pr-str eid-or-ref) ".") + {:type :eacl/invalid-entity-id + :value eid-or-ref})))) + +(defn attr-ident + "A datom's `:a` as an ident. Datahike reports `:a` as the attribute keyword by + default and as a numeric ref under `:attribute-refs? true` (Datomic's + representation), so code that compares `:a` against a keyword set matches + nothing in the second mode without this." + [db a] + (if (number? a) (:db/ident (d/entity db a)) a)) + +(defn attribute-refs? + "Whether this db represents attributes as numeric refs (Datomic's + representation) rather than as keywords. A creation-time choice, so it is + constant for the life of the database." + [db] + (boolean (:attribute-refs? (:config db)))) + +(defn attr-repr + "`attr` in the representation this db uses for it: the keyword itself, or its + numeric ref under `:attribute-refs?`. Resolved once per operation rather than + per datom — an entity lookup per datom would dominate an index scan." + [db attr] + (if (attribute-refs? db) + (entid db attr) + attr)) + +(defn seek-tuple-prefix + "Datoms of composite-tuple attribute `attr` (of `arity` components) whose + value begins with `prefix`. + + Two datahike facts make the obvious spelling silently wrong. A partial tuple + is not a valid seek bound: datahike sorts vectors length-first (as DataScript + does — Datomic is the outlier here), so a short bound lands at the head of + the whole attribute and the seek returns everything. Hence the pad to full + arity with `nil`, which sorts lowest and positions at the exact prefix. And + `seek-datoms` runs off the end of the attribute into the next one, hence the + `:a` guard rather than just a value check." + [db attr arity prefix] + (let [prefix (vec prefix) + n (count prefix) + padded (into prefix (repeat (- arity n) nil)) + a-repr (attr-repr db attr)] + (->> (d/seek-datoms db {:index :avet :components [attr padded]}) + (take-while (fn [{:keys [a v]}] + (and (= a-repr a) + (vector? v) + (<= n (count v)) + (= prefix (subvec v 0 n)))))))) + +(defn avet-datoms + "Datoms of `attr`, optionally restricted to an exact value." + ([db attr] (d/datoms db {:index :avet :components [attr]})) + ([db attr v] (d/datoms db {:index :avet :components [attr v]}))) + +(defn avet-range + "Datoms of `attr` whose value falls in [`start`, `end`]. Datahike's + `index-range` takes a map where DataScript takes positional arguments; tuple + values are valid bounds here, unlike a partial tuple in a seek. + + `:attrid` is the one place datahike does NOT accept the attribute keyword in + both modes: under `:attribute-refs?` it demands the numeric ref and raises + otherwise. It raises rather than denying, which is why this surfaced as an + error instead of a wrong answer." + [db attr start end] + (d/index-range db {:attrid (attr-repr db attr) :start start :end end})) + +(defn entity-exists? + "Whether `eid` has any datom. `entid` passes unallocated numeric ids through + unchanged, so presence has to be checked separately." + [db eid] + (boolean (seq (d/datoms db {:index :eavt :components [eid]})))) diff --git a/modules/eacl-datahike/src/eacl/datahike/impl.clj b/modules/eacl-datahike/src/eacl/datahike/impl.clj new file mode 100644 index 000000000..4cd76394b --- /dev/null +++ b/modules/eacl-datahike/src/eacl/datahike/impl.clj @@ -0,0 +1,481 @@ +(ns eacl.datahike.impl + (:require [datahike.api :as d] + [eacl.core :as eacl :refer [spice-object]] + [eacl.datahike.db :as ddb] + [eacl.datahike.schema :as schema] + [eacl.engine.indexed :as engine] + [eacl.engine.relationships :as relationship-engine] + [eacl.schema.model :as model])) + +(def Relation model/Relation) +(def Permission model/Permission) + +(defn Relationship + [subject relation resource] + (eacl/->Relationship subject relation resource)) + +(def permission-paths-cache + (atom {})) + +(def max-entid schema/max-entid) + +(def permission-def-pull + '[:db/id + :eacl.permission/resource-type + :eacl.permission/permission-name + :eacl.permission/source-relation-name + :eacl.permission/target-type + :eacl.permission/target-name]) + +(defn evict-permission-paths-cache! + ([] (evict-permission-paths-cache! permission-paths-cache)) + ([cache-atom] + (engine/evict-permission-paths-cache! cache-atom))) + +(defn relation-datoms + "Returns relation datoms for the exact resource/relation name pair, for ANY + subject-type keyword. Implemented as a seek + prefix take-while rather than a + bounded index-range: a keyword-sentinel range like [.. :a]..[.. :z] silently + misses subject types that collate outside it (uppercase-initial, z-prefixed, + and namespaced keywords), making those relations invisible to permission + evaluation (audit 2)." + [db resource-type relation-name] + (if (and resource-type relation-name) + (ddb/seek-tuple-prefix db schema/relation-key-attr 3 [resource-type relation-name]) + [])) + +(defn find-relation-def + [db resource-type relation-name] + (when-let [datom (first (relation-datoms db resource-type relation-name))] + (d/pull db + '[:db/id + :eacl.relation/subject-type + :eacl.relation/resource-type + :eacl.relation/relation-name] + (:e datom)))) + +(defn find-permission-defs + [db resource-type permission-name] + (->> (ddb/avet-datoms db schema/permission-key-attr [resource-type permission-name]) + (map :e) + (mapv #(d/pull db permission-def-pull %)))) + +(defn all-relation-defs + [db] + (mapv (fn [{:keys [e v]}] + {:relation-id e + :resource-type (nth v 0) + :relation-name (nth v 1) + :subject-type (nth v 2)}) + (ddb/avet-datoms db schema/relation-key-attr))) + +(defn- exclusive-start-id + [cursor-id] + (if cursor-id + (inc cursor-id) + 0)) + +(defn- bounded-relationship-target-ids + [db attr prefix cursor-id] + (->> (ddb/avet-range db + attr + (conj prefix (exclusive-start-id cursor-id)) + (conj prefix max-entid)) + (map (fn [{:keys [v]}] (peek v))))) + +(defn subject->resources + [db subject-type subject-id relation-id resource-type cursor-resource-id] + (bounded-relationship-target-ids db + schema/forward-relationship-attr + [subject-type subject-id relation-id resource-type] + cursor-resource-id)) + +(defn resource->subjects + [db resource-type resource-id relation-id subject-type cursor-subject-id] + (bounded-relationship-target-ids db + schema/reverse-relationship-attr + [resource-type resource-id relation-id subject-type] + cursor-subject-id)) + +(defn build-schema-catalog + [db] + {:relation-defs + (reduce (fn [idx {:keys [e v]}] + (let [[resource-type relation-name subject-type] v + relation-def {:relation-id e + :resource-type resource-type + :relation-name relation-name + :subject-type subject-type}] + (update idx [resource-type relation-name] (fnil conj []) relation-def))) + {} + (ddb/avet-datoms db schema/relation-key-attr)) + :permission-defs + (reduce (fn [idx {:keys [e]}] + (let [perm (d/pull db permission-def-pull e)] + (update idx + [(:eacl.permission/resource-type perm) + (:eacl.permission/permission-name perm)] + (fnil conj []) + perm))) + {} + (ddb/avet-datoms db schema/permission-key-attr))}) + +(defn- relationship-tuple + [{:keys [subject-type subject-id relation-id resource-type resource-id]}] + [subject-type subject-id relation-id resource-type resource-id]) + +(defn- internal-id + [db value] + (when value + (ddb/entid db value))) + +(defn- existing-internal-id + "Resolves to an eid and verifies the entity exists (datom presence - entid + passes unallocated numeric ids through unchanged). Throws :eacl/unknown-object + otherwise: nil ids reaching tx-data raised raw transact errors, and silent + no-ops hid typos (audit 11/12)." + [db {:keys [type id]}] + (let [eid (internal-id db id)] + (if (and eid (ddb/entity-exists? db eid)) + eid + (throw (ex-info (str "Unknown object: " (pr-str type) " with id " (pr-str id) " does not exist.") + {:type :eacl/unknown-object + :object {:type type :id id}}))))) + +(defn- relation-id + [resource-type relation-name subject-type] + [:eacl/id (model/->relation-id resource-type relation-name subject-type)]) + +(defn- resolve-relationship + [db {:keys [subject relation resource]}] + (let [subject-type (:type subject) + subject-id (existing-internal-id db subject) + resource-type (:type resource) + resource-id (existing-internal-id db resource) + relation-eid (ddb/entid db (relation-id resource-type relation subject-type))] + (when-not relation-eid + (throw + (ex-info + (str "Missing Relation: " relation + " on resource type " resource-type + " for subject type " subject-type ".") + {:resource/type resource-type + :relation/name relation + :subject/type subject-type}))) + {:subject subject + :subject-type subject-type + :subject-id subject-id + :relation relation + :relation-id relation-eid + :resource resource + :resource-type resource-type + :resource-id resource-id})) + +(defn find-one-relationship-id + "Returns the resolved tuple identity for an existing relationship, or nil. + A read: unresolvable endpoints mean no such relationship can exist -> nil." + [db relationship] + (let [resolved (try + (resolve-relationship db relationship) + (catch clojure.lang.ExceptionInfo e + (when-not (= :eacl/unknown-object (:type (ex-data e))) + (throw e)))) + existing (when resolved + (ddb/entid db [schema/relationship-full-key-attr + (relationship-tuple resolved)]))] + (when existing + resolved))) + +(defn- relationship-entity + [resolved] + {:eacl.relationship/subject-type (:subject-type resolved) + :eacl.relationship/subject (:subject-id resolved) + :eacl.relationship/relation (:relation-id resolved) + :eacl.relationship/resource-type (:resource-type resolved) + :eacl.relationship/resource (:resource-id resolved)}) + +(defn tx-update-relationship + [db {:keys [operation relationship]}] + (let [resolved (resolve-relationship db relationship) + tuple (relationship-tuple resolved) + existing (ddb/entid db [schema/relationship-full-key-attr tuple])] + (case operation + :touch + (when-not existing + [(relationship-entity resolved)]) + + :create + (if existing + (throw (ex-info ":create relationship conflicts with existing tuple relationship" + {:relationship relationship})) + [(relationship-entity resolved)]) + + :delete + (when existing + [[:db/retractEntity existing]]) + + :unspecified + [(relationship-entity resolved)] + + (throw (ex-info "Unknown relationship operation" + {:operation operation}))))) + +(defn read-relationships + [db filters] + (let [subject-id' (when (contains? filters :subject/id) + (internal-id db (:subject/id filters))) + resource-id' (when (contains? filters :resource/id) + (internal-id db (:resource/id filters))) + filters' (cond-> filters + (contains? filters :subject/id) (assoc :subject/id subject-id') + (contains? filters :resource/id) (assoc :resource/id resource-id'))] + (if (or (and (contains? filters :subject/id) (nil? subject-id')) + (and (contains? filters :resource/id) (nil? resource-id'))) + {:data [] :cursor nil} + (letfn [(relationship-row [spec subject-id resource-id] + {:spec-idx (:idx spec) + :subject-id subject-id + :resource-id resource-id + :relationship + (eacl/->Relationship + (spice-object (:subject-type spec) subject-id) + (:relation-name spec) + (spice-object (:resource-type spec) resource-id))}) + (drop-until-after-cursor [spec cursor rows] + (drop-while #(not (relationship-engine/after-cursor? (:scan-kind spec) cursor %)) + rows)) + (exact-match-row [spec cursor] + (let [row (when (and (:subject-id spec) (:resource-id spec)) + (when (ddb/entid db [schema/relationship-full-key-attr + [(:subject-type spec) + (:subject-id spec) + (:relation-id spec) + (:resource-type spec) + (:resource-id spec)]]) + (relationship-row spec (:subject-id spec) (:resource-id spec))))] + (if row + (drop-until-after-cursor spec cursor [row]) + []))) + (scan-forward-anchored [spec cursor] + (if (:resource-id spec) + (exact-match-row spec cursor) + (->> (ddb/avet-range db + schema/forward-relationship-attr + [(:subject-type spec) + (:subject-id spec) + (:relation-id spec) + (:resource-type spec) + (or (:resource cursor) 0)] + [(:subject-type spec) + (:subject-id spec) + (:relation-id spec) + (:resource-type spec) + max-entid]) + (map (fn [{:keys [v]}] + (relationship-row spec (nth v 1) (nth v 4)))) + (drop-until-after-cursor spec cursor)))) + (scan-reverse-anchored [spec cursor] + (if (:subject-id spec) + (exact-match-row spec cursor) + (->> (ddb/avet-range db + schema/reverse-relationship-attr + [(:resource-type spec) + (:resource-id spec) + (:relation-id spec) + (:subject-type spec) + (or (:subject cursor) 0)] + [(:resource-type spec) + (:resource-id spec) + (:relation-id spec) + (:subject-type spec) + max-entid]) + (map (fn [{:keys [v]}] + (relationship-row spec (nth v 4) (nth v 1)))) + (drop-until-after-cursor spec cursor)))) + (scan-forward-partial [spec cursor] + (->> (ddb/avet-range db + schema/forward-partial-relationship-attr + [(:subject-type spec) + (:relation-id spec) + (:resource-type spec) + (or (:resource cursor) 0) + 0] + [(:subject-type spec) + (:relation-id spec) + (:resource-type spec) + max-entid + max-entid]) + (map (fn [{:keys [v]}] + (relationship-row spec (nth v 4) (nth v 3)))) + (drop-until-after-cursor spec cursor))) + (scan-reverse-partial [spec cursor] + (->> (ddb/avet-range db + schema/reverse-partial-relationship-attr + [(:resource-type spec) + (:relation-id spec) + (:subject-type spec) + (or (:subject cursor) 0) + 0] + [(:resource-type spec) + (:relation-id spec) + (:subject-type spec) + max-entid + max-entid]) + (map (fn [{:keys [v]}] + (relationship-row spec (nth v 3) (nth v 4)))) + (drop-until-after-cursor spec cursor))) + (scan-spec [spec cursor] + (case (:scan-kind spec) + :forward-anchored (scan-forward-anchored spec cursor) + :reverse-anchored (scan-reverse-anchored spec cursor) + :forward-partial (scan-forward-partial spec cursor) + (scan-reverse-partial spec cursor)))] + (relationship-engine/execute-plan + (relationship-engine/plan-scans (all-relation-defs db) filters') + filters' + scan-spec))))) + +(defn- normalize-backend-options + [cache-stamp-or-opts] + (cond + (nil? cache-stamp-or-opts) {} + (fn? cache-stamp-or-opts) {:cache-stamp cache-stamp-or-opts} + (map? cache-stamp-or-opts) cache-stamp-or-opts + :else (throw (ex-info "Unsupported Datahike backend options" + {:value cache-stamp-or-opts})))) + +(defn- schema-catalog-data + [db schema-catalog] + (cond + (nil? schema-catalog) nil + (fn? schema-catalog) (schema-catalog db) + :else schema-catalog)) + +(defn- relation-defs-from-db + [db resource-type relation-name] + (mapv (fn [datom] + {:relation-id (:e datom) + :resource-type resource-type + :relation-name relation-name + :subject-type (nth (:v datom) 2)}) + (relation-datoms db resource-type relation-name))) + +(defn- ->permission-def + [perm] + {:permission-id (:db/id perm) + :resource-type (:eacl.permission/resource-type perm) + :permission-name (:eacl.permission/permission-name perm) + :source-relation-name (:eacl.permission/source-relation-name perm) + :target-type (:eacl.permission/target-type perm) + :target-name (:eacl.permission/target-name perm)}) + +(defn- permission-defs-from-db + [db resource-type permission-name] + (mapv ->permission-def (find-permission-defs db resource-type permission-name))) + +(defn indexed-backend + ([db] + (indexed-backend db nil)) + ([db cache-stamp-or-opts] + (let [{:keys [cache-stamp + schema-catalog] + :as options} (normalize-backend-options cache-stamp-or-opts) + permission-paths-cache-atom (:permission-paths-cache options)] + {:cache-stamp (or cache-stamp + (fn [] + (hash db))) + :permission-paths-cache (or permission-paths-cache-atom permission-paths-cache) + :relation-defs (fn [resource-type relation-name] + (if-let [catalog (schema-catalog-data db schema-catalog)] + (get-in catalog [:relation-defs [resource-type relation-name]] []) + (relation-defs-from-db db resource-type relation-name))) + :permission-defs (fn [resource-type permission-name] + (if-let [catalog (schema-catalog-data db schema-catalog)] + (mapv ->permission-def + (get-in catalog [:permission-defs [resource-type permission-name]] [])) + (permission-defs-from-db db resource-type permission-name))) + :subject->resources (fn [subject-type subject-id relation-id resource-type cursor-resource-id] + (subject->resources db subject-type subject-id relation-id resource-type cursor-resource-id)) + :resource->subjects (fn [resource-type resource-id relation-id subject-type cursor-subject-id] + (resource->subjects db resource-type resource-id relation-id subject-type cursor-subject-id)) + :direct-match? (fn [subject-type subject-id relation-id resource-type resource-id] + (boolean + (ddb/entid db [schema/relationship-full-key-attr + [subject-type subject-id relation-id resource-type resource-id]])))}))) + +(defn- backend* + [db-or-backend] + (if (and (map? db-or-backend) (contains? db-or-backend :cache-stamp)) + db-or-backend + (indexed-backend db-or-backend))) + +(defn calc-permission-paths + ([db-or-backend resource-type permission-name] + (engine/calc-permission-paths (backend* db-or-backend) resource-type permission-name)) + ([db-or-backend resource-type permission-name visited-perms] + (engine/calc-permission-paths (backend* db-or-backend) resource-type permission-name visited-perms))) + +(defn get-permission-paths + [db-or-backend resource-type permission-name] + (let [backend (backend* db-or-backend) + cache-atom (or (:permission-paths-cache backend) permission-paths-cache)] + (engine/get-permission-paths cache-atom calc-permission-paths backend resource-type permission-name))) + +(defn can? + ([db subject permission resource] + (can? db nil subject permission resource)) + ([db cache-stamp-or-opts subject permission resource] + (let [subject-id (internal-id db (:id subject)) + resource-id (internal-id db (:id resource))] + (engine/can? + (indexed-backend db cache-stamp-or-opts) + get-permission-paths + (assoc subject :id subject-id) + permission + (assoc resource :id resource-id))))) + +(defn- internalize-anchor + [db object] + (update object :id #(internal-id db %))) + +(defn lookup-resources + ([db query] + (lookup-resources db nil query)) + ([db cache-stamp-or-opts query] + (engine/lookup + (indexed-backend db cache-stamp-or-opts) + engine/forward-direction + get-permission-paths + (update query :subject #(internalize-anchor db %))))) + +(defn lookup-subjects + ([db query] + (lookup-subjects db nil query)) + ([db cache-stamp-or-opts query] + (engine/lookup + (indexed-backend db cache-stamp-or-opts) + engine/reverse-direction + get-permission-paths + (update query :resource #(internalize-anchor db %))))) + +(defn count-resources + ([db query] + (count-resources db nil query)) + ([db cache-stamp-or-opts query] + (engine/count-results + (indexed-backend db cache-stamp-or-opts) + engine/forward-direction + get-permission-paths + (update query :subject #(internalize-anchor db %)) + :resource))) + +(defn count-subjects + ([db query] + (count-subjects db nil query)) + ([db cache-stamp-or-opts query] + (engine/count-results + (indexed-backend db cache-stamp-or-opts) + engine/reverse-direction + get-permission-paths + (update query :resource #(internalize-anchor db %)) + :subject))) diff --git a/modules/eacl-datahike/src/eacl/datahike/schema.clj b/modules/eacl-datahike/src/eacl/datahike/schema.clj new file mode 100644 index 000000000..405f7789a --- /dev/null +++ b/modules/eacl-datahike/src/eacl/datahike/schema.clj @@ -0,0 +1,319 @@ +(ns eacl.datahike.schema + (:require [datahike.api :as d] + [eacl.datahike.db :as ddb] + [eacl.schema.model :as model] + [eacl.spicedb.parser :as parser])) + +(def forward-relationship-attr + :eacl.v7.relationship/subject-type+subject+relation+resource-type+resource) + +(def reverse-relationship-attr + :eacl.v7.relationship/resource-type+resource+relation+subject-type+subject) + +(def forward-partial-relationship-attr + :eacl.v7.relationship/subject-type+relation+resource-type+resource+subject) + +(def reverse-partial-relationship-attr + :eacl.v7.relationship/resource-type+relation+subject-type+subject+resource) + +(def relationship-full-key-attr + :eacl.relationship/full-key) + +(def relation-key-attr + :eacl.relation/resource-type+relation-name+subject-type) + +(def permission-key-attr + :eacl.permission/resource-type+permission-name) + +(def max-entid Long/MAX_VALUE) + +(def schema-change-attrs + #{:eacl.relation/resource-type + :eacl.relation/relation-name + :eacl.relation/subject-type + :eacl.relation/resource-type+relation-name+subject-type + :eacl.permission/resource-type + :eacl.permission/permission-name + :eacl.permission/source-relation-name + :eacl.permission/target-type + :eacl.permission/target-name + :eacl.permission/resource-type+permission-name + :eacl.permission/full-key + :eacl/schema-string}) + +(def ^:private component-schema + "The attributes composite tuples are derived FROM. Datahike's `:write` + flexibility needs a declared `:db/valueType` and `:db/cardinality` on every + attribute, which DataScript's schema map leaves implicit." + [{:db/ident :eacl/id + :db/valueType :db.type/string + :db/cardinality :db.cardinality/one + :db/unique :db.unique/identity} + {:db/ident :eacl/schema-string + :db/valueType :db.type/string + :db/cardinality :db.cardinality/one} + + {:db/ident :eacl.relation/resource-type + :db/valueType :db.type/keyword + :db/cardinality :db.cardinality/one + :db/index true} + {:db/ident :eacl.relation/relation-name + :db/valueType :db.type/keyword + :db/cardinality :db.cardinality/one + :db/index true} + {:db/ident :eacl.relation/subject-type + :db/valueType :db.type/keyword + :db/cardinality :db.cardinality/one + :db/index true} + + {:db/ident :eacl.permission/resource-type + :db/valueType :db.type/keyword + :db/cardinality :db.cardinality/one + :db/index true} + {:db/ident :eacl.permission/permission-name + :db/valueType :db.type/keyword + :db/cardinality :db.cardinality/one + :db/index true} + {:db/ident :eacl.permission/source-relation-name + :db/valueType :db.type/keyword + :db/cardinality :db.cardinality/one + :db/index true} + {:db/ident :eacl.permission/target-type + :db/valueType :db.type/keyword + :db/cardinality :db.cardinality/one + :db/index true} + {:db/ident :eacl.permission/target-name + :db/valueType :db.type/keyword + :db/cardinality :db.cardinality/one + :db/index true} + + {:db/ident :eacl.relationship/subject + :db/valueType :db.type/ref + :db/cardinality :db.cardinality/one} + {:db/ident :eacl.relationship/relation + :db/valueType :db.type/ref + :db/cardinality :db.cardinality/one} + {:db/ident :eacl.relationship/resource + :db/valueType :db.type/ref + :db/cardinality :db.cardinality/one} + {:db/ident :eacl.relationship/subject-type + :db/valueType :db.type/keyword + :db/cardinality :db.cardinality/one + :db/index true} + {:db/ident :eacl.relationship/resource-type + :db/valueType :db.type/keyword + :db/cardinality :db.cardinality/one + :db/index true}]) + +(def ^:private tuple-schema + "The composite tuples. These ARE the v7 engine: every relationship traversal + is a bounded range over one of the four orderings below, so each must be + indexed. Deriving them requires datahike >= 0.8.1759 (replikativ/datahike#921) + under `:attribute-refs?`; before that fix they were silently never derived, + and every permission check denied." + [{:db/ident :eacl.relation/resource-type+relation-name+subject-type + :db/valueType :db.type/tuple + :db/tupleAttrs [:eacl.relation/resource-type + :eacl.relation/relation-name + :eacl.relation/subject-type] + :db/cardinality :db.cardinality/one + :db/unique :db.unique/identity} + + {:db/ident :eacl.permission/resource-type+permission-name + :db/valueType :db.type/tuple + :db/tupleAttrs [:eacl.permission/resource-type + :eacl.permission/permission-name] + :db/cardinality :db.cardinality/one + :db/index true} + {:db/ident :eacl.permission/full-key + :db/valueType :db.type/tuple + :db/tupleAttrs [:eacl.permission/resource-type + :eacl.permission/source-relation-name + :eacl.permission/target-type + :eacl.permission/target-name + :eacl.permission/permission-name] + :db/cardinality :db.cardinality/one + :db/unique :db.unique/identity} + + {:db/ident :eacl.relationship/full-key + :db/valueType :db.type/tuple + :db/tupleAttrs [:eacl.relationship/subject-type + :eacl.relationship/subject + :eacl.relationship/relation + :eacl.relationship/resource-type + :eacl.relationship/resource] + :db/cardinality :db.cardinality/one + :db/unique :db.unique/identity} + {:db/ident forward-relationship-attr + :db/valueType :db.type/tuple + :db/tupleAttrs [:eacl.relationship/subject-type + :eacl.relationship/subject + :eacl.relationship/relation + :eacl.relationship/resource-type + :eacl.relationship/resource] + :db/cardinality :db.cardinality/one + :db/index true} + {:db/ident reverse-relationship-attr + :db/valueType :db.type/tuple + :db/tupleAttrs [:eacl.relationship/resource-type + :eacl.relationship/resource + :eacl.relationship/relation + :eacl.relationship/subject-type + :eacl.relationship/subject] + :db/cardinality :db.cardinality/one + :db/index true} + {:db/ident forward-partial-relationship-attr + :db/valueType :db.type/tuple + :db/tupleAttrs [:eacl.relationship/subject-type + :eacl.relationship/relation + :eacl.relationship/resource-type + :eacl.relationship/resource + :eacl.relationship/subject] + :db/cardinality :db.cardinality/one + :db/index true} + {:db/ident reverse-partial-relationship-attr + :db/valueType :db.type/tuple + :db/tupleAttrs [:eacl.relationship/resource-type + :eacl.relationship/relation + :eacl.relationship/subject-type + :eacl.relationship/subject + :eacl.relationship/resource] + :db/cardinality :db.cardinality/one + :db/index true}]) + +(def datahike-schema + "EACL's own attributes, as datahike transaction data." + (into component-schema tuple-schema)) + +(defn merge-schema + "EACL's attributes plus the caller's. `extra-schema` is datahike-native + transaction data (a sequence of attribute maps), NOT DataScript's map of + attribute to options: datahike's `:write` flexibility needs value types that + a DataScript schema map does not carry, so the two are not interconvertible." + ([] datahike-schema) + ([extra-schema] + (if (seq extra-schema) + (into datahike-schema extra-schema) + datahike-schema))) + +(def default-config + {:store {:backend :memory} + :schema-flexibility :write + :keep-history? false + ;; EACL object ids come from the caller, so no cap is imposed here; stating 0 + ;; declares that as intentional rather than leaving datahike to warn about it. + :max-string-length 0}) + +(defn create-conn + "A datahike connection carrying EACL's schema. + + `config` is merged over `default-config`; pass `{:attribute-refs? true}` to get + Datomic's numeric attribute representation. A memory store gets a fresh id per + connection unless one is supplied, so two calls do not collide." + ([] (create-conn nil nil)) + ([extra-schema] (create-conn extra-schema nil)) + ([extra-schema config] + (let [cfg (-> (merge default-config config) + (update :store #(merge {:id (random-uuid)} %)))] + (d/create-database cfg) + (let [conn (d/connect cfg)] + (d/transact conn (merge-schema extra-schema)) + conn)))) + +(def relation-pull + '[:eacl/id + :eacl.relation/subject-type + :eacl.relation/resource-type + :eacl.relation/relation-name]) + +(def permission-pull + '[:eacl/id + :eacl.permission/resource-type + :eacl.permission/permission-name + :eacl.permission/source-relation-name + :eacl.permission/target-type + :eacl.permission/target-name]) + +(defn read-relations + "Every relation definition. Enumerated from the relation key index rather than + by query: the index is the engine's own view of the schema, so a relation + that is invisible here is invisible to permission evaluation too." + [db] + (mapv #(d/pull db relation-pull (:e %)) + (ddb/avet-datoms db relation-key-attr))) + +(defn read-permissions + [db] + (mapv #(d/pull db permission-pull (:e %)) + (ddb/avet-datoms db permission-key-attr))) + +(defn read-schema + [db & [_format]] + {:relations (read-relations db) + :permissions (read-permissions db)}) + +(def validate-schema-references model/validate-schema-references) +(def calc-set-deltas model/calc-set-deltas) +(def compare-schema model/compare-schema) + +(defn count-relationships-using-relation + "Counts relationships that reference the given relation, exactly. + Scans the forward-partial index whose leading components are + [subject-type relation]; a range over the forward index with varying middle + components would span other relations of the same subject-type and overcount." + [db {:eacl.relation/keys [resource-type relation-name subject-type]}] + (let [relation-id (model/->relation-id resource-type relation-name subject-type) + relation-eid (ddb/entid db [:eacl/id relation-id])] + (if-not relation-eid + 0 + (count (ddb/seek-tuple-prefix db forward-partial-relationship-attr 5 + [subject-type relation-eid]))))) + +(defn write-schema! + "Parses, validates, diffs and transacts a SpiceDB schema string. + Throws :eacl.schema/parse-error on unparseable input (a failed parse must + never retract the stored schema) and :eacl.schema/empty-schema-guard when the + new schema has zero definitions while a non-empty schema is stored; pass + {:allow-empty-schema? true} to wipe intentionally." + ([conn schema-string] + (write-schema! conn schema-string {})) + ([conn schema-string {:keys [allow-empty-schema?]}] + (let [new-schema-map (parser/->eacl-schema (parser/parse-schema schema-string)) + _ (validate-schema-references new-schema-map) + db (d/db conn) + existing-schema (read-schema db) + _ (when (and (empty? (:definitions new-schema-map)) + (not allow-empty-schema?) + (or (seq (:relations existing-schema)) + (seq (:permissions existing-schema)))) + (throw (ex-info (str "Refusing to replace a non-empty schema with zero definitions." + " Pass {:allow-empty-schema? true} to write-schema! if this is intentional.") + {:type :eacl.schema/empty-schema-guard + :existing {:relations (count (:relations existing-schema)) + :permissions (count (:permissions existing-schema))}}))) + deltas (compare-schema existing-schema new-schema-map) + {:keys [relations permissions]} deltas + relation-retractions (:retractions relations) + permission-retractions (:retractions permissions)] + (doseq [rel relation-retractions] + (let [cnt (count-relationships-using-relation db rel)] + (when (pos? cnt) + (throw (ex-info (str "Cannot delete relation " (:eacl.relation/relation-name rel) + " because it is used by " cnt " relationships.") + {:relation rel :count cnt}))))) + (d/transact conn + (vec + (concat + (:additions relations) + (:additions permissions) + (for [rel relation-retractions + :let [eid (ddb/entid db [:eacl/id (:eacl/id rel)])] + :when eid] + [:db/retractEntity eid]) + (for [perm permission-retractions + :let [eid (ddb/entid db [:eacl/id (:eacl/id perm)])] + :when eid] + [:db/retractEntity eid]) + [{:eacl/id "schema-string" + :eacl/schema-string schema-string}]))) + deltas))) diff --git a/modules/eacl-datahike/test/eacl/datahike/backend_test.clj b/modules/eacl-datahike/test/eacl/datahike/backend_test.clj new file mode 100644 index 000000000..dfce9f26e --- /dev/null +++ b/modules/eacl-datahike/test/eacl/datahike/backend_test.clj @@ -0,0 +1,148 @@ +(ns eacl.datahike.backend-test + "Datahike-specific tests for the paths the shared contract does not reach. + + `assert-seeded-contracts!` goes through `make-client`, which serves relation + definitions from a prebuilt schema catalog — a full index scan. So the + contract suite never exercises the tuple SEEK, which is where datahike's + length-first vector ordering bites, nor cache invalidation on a schema + change, which is where the numeric attribute representation bites. + + They fail in OPPOSITE directions, and neither is visible without a test that + names it: a mispositioned seek finds no relation definition and DENIES, while + a listener that fails to recognise a schema change keeps answering from + pre-change permission paths and so GRANTS what the schema has just revoked. + + Every test runs in both attribute representations. The stale-cache failure + appears ONLY under :attribute-refs?, where a datom's :a is a number." + (:require [clojure.test :refer [deftest is testing]] + [datahike.api :as d] + [eacl.contract-support :as contract] + [eacl.core :as eacl] + [eacl.datahike.core :as datahike] + [eacl.datahike.db :as ddb] + [eacl.datahike.impl :as impl] + [eacl.datahike.schema :as schema])) + +(def ^:private modes + {"attributes as keywords" nil + "attributes as numeric refs" {:attribute-refs? true}}) + +(defn- seeded-conn + "The contract's schema, objects and relationships, so these tests describe the + same world the contract does." + [config] + (let [conn (datahike/create-conn nil config) + client (datahike/make-client conn {})] + (eacl/write-schema! client contract/smoke-schema) + (d/transact conn + (vec (map-indexed (fn [idx {:keys [id]}] + {:db/id (- (inc idx)) :eacl/id id}) + contract/smoke-objects))) + (eacl/create-relationships! client contract/smoke-relationships) + [conn client])) + +(deftest seek-positions-at-the-prefix-not-the-head-of-the-attribute + (doseq [[label config] modes] + (testing label + (let [[conn _] (seeded-conn config) + db (d/db conn) + defs (impl/relation-datoms db :server :account)] + (is (= 1 (count defs)) + "the exact [resource-type relation-name] prefix, and nothing else") + (is (= [[:server :account :account]] (mapv :v defs))) + ;; The head of this attribute sorts BEFORE the wanted prefix + ;; ([:account :owner :user] < [:server :account :account]), so an + ;; unpadded seek bound is ignored, the scan starts at the head, and the + ;; prefix take-while stops immediately with zero results. + (is (not= [:server :account] + (vec (take 2 (:v (first (ddb/avet-datoms db schema/relation-key-attr)))))) + "precondition: the wanted relation is not the first datom of the attribute"))))) + +(deftest can-answers-without-a-prebuilt-schema-catalog + ;; impl/can? on a bare db takes relation-defs straight from the index, which + ;; is the seek path make-client's catalog bypasses. + (doseq [[label config] modes] + (testing label + (let [[conn _] (seeded-conn config) + db (d/db conn) + user (fn [id] (eacl/spice-object :user [:eacl/id id])) + server (fn [id] (eacl/spice-object :server [:eacl/id id]))] + (is (true? (impl/can? db (user "user-1") :reboot (server "server-1")))) + (is (true? (impl/can? db (user "super-user") :reboot (server "server-2")))) + (is (false? (impl/can? db (user "user-2") :reboot (server "server-1")))))))) + +(deftest a-relation-in-use-cannot-be-dropped-from-the-schema + ;; The guard counts via the forward-partial seek, so an under-counting seek + ;; would let a schema write orphan live relationships. + (doseq [[label config] modes] + (testing label + (let [[conn client] (seeded-conn config) + db (d/db conn)] + (is (= 1 (schema/count-relationships-using-relation + db + {:eacl.relation/resource-type :account + :eacl.relation/relation-name :owner + :eacl.relation/subject-type :user})) + "user-1 owns account-1") + (is (= 2 (schema/count-relationships-using-relation + db + {:eacl.relation/resource-type :server + :eacl.relation/relation-name :account + :eacl.relation/subject-type :account})) + "account-1 holds both servers") + (is (= 0 (schema/count-relationships-using-relation + db + {:eacl.relation/resource-type :account + :eacl.relation/relation-name :owner + :eacl.relation/subject-type :account})) + "a relation that exists in neither the schema nor the data") + (is (thrown-with-msg? + clojure.lang.ExceptionInfo #"because it is used by 1 relationships" + (eacl/write-schema! + client + "definition user {} + definition platform { relation super_admin: user } + definition account { + relation platform: platform + permission admin = platform->super_admin + permission view = admin + } + definition server { + relation account: account + permission view = account->view + permission reboot = account->admin + }"))))))) + +(deftest a-schema-change-invalidates-cached-permission-paths + ;; Permission paths are cached per conn and evicted by a tx listener that + ;; recognises EACL's schema attributes in the tx-data. Under + ;; :attribute-refs? a datom's :a is a NUMBER, so a listener comparing :a + ;; against a keyword set recognises nothing, and can? keeps answering from the + ;; pre-change paths — granting access the new schema does not. + (doseq [[label config] modes] + (testing label + (let [[_ client] (seeded-conn config) + user-1 (eacl/spice-object :user "user-1") + server-1 (eacl/spice-object :server "server-1")] + (is (true? (eacl/can? client user-1 :reboot server-1)) + "user-1 reboots as the account owner, and the path is now cached") + ;; admin no longer follows from ownership, only from platform super-admin. + (eacl/write-schema! + client + "definition user {} + definition platform { relation super_admin: user } + definition account { + relation platform: platform + relation owner: user + permission admin = platform->super_admin + permission view = admin + } + definition server { + relation account: account + permission view = account->view + permission reboot = account->admin + }") + (is (false? (eacl/can? client user-1 :reboot server-1)) + "the owner path is gone from the schema, so the cached answer must not stand") + (is (true? (eacl/can? client (eacl/spice-object :user "super-user") :reboot server-1)) + "and the surviving path still resolves"))))) diff --git a/modules/eacl-datahike/test/eacl/datahike/contract_test.clj b/modules/eacl-datahike/test/eacl/datahike/contract_test.clj index 65e082c40..6411978da 100644 --- a/modules/eacl-datahike/test/eacl/datahike/contract_test.clj +++ b/modules/eacl-datahike/test/eacl/datahike/contract_test.clj @@ -2,8 +2,16 @@ "The shared backend contract, on Datahike. A backend is finished when this passes — it is the same suite `eacl.datascript.contract-test` runs, so the two backends are held to one definition rather than to separate tests that - drifted." - (:require [clojure.test :refer [deftest]] + drifted. + + The suite runs TWICE, once per attribute representation. Datahike reports a + datom's `:a` as the attribute keyword by default and as a numeric ref under + `:attribute-refs? true` (Datomic's representation), and the second mode is + the one that fails silently rather than loudly: composite tuples need + replikativ/datahike#921 to be derived at all, and any code comparing `:a` + against a keyword simply stops matching. Both are permission DENIALS, so a + single-mode suite would go green while every check answered false." + (:require [clojure.test :refer [deftest testing]] [datahike.api :as d] [eacl.contract-support :as contract] [eacl.core :as eacl] @@ -14,15 +22,23 @@ tempids, as in the DataScript contract test." [conn] (d/transact conn - (map-indexed (fn [idx {:keys [id]}] - {:db/id (- (inc idx)) - :eacl/id id}) - contract/smoke-objects))) + (vec (map-indexed (fn [idx {:keys [id]}] + {:db/id (- (inc idx)) + :eacl/id id}) + contract/smoke-objects)))) -(deftest datahike-contract-test - (let [conn (datahike/create-conn) +(defn- run-contract! + [config] + (let [conn (datahike/create-conn nil config) client (datahike/make-client conn {})] (eacl/write-schema! client contract/smoke-schema) (seed-objects! conn) (eacl/create-relationships! client contract/smoke-relationships) (contract/assert-seeded-contracts! client))) + +(deftest datahike-contract-test + (testing "attributes as keywords (datahike's default)" + (run-contract! nil)) + + (testing "attributes as numeric refs (:attribute-refs?, Datomic's representation)" + (run-contract! {:attribute-refs? true}))) From adf9cbcc2dd7e0104c1e93f0e19235e0d933ac36 Mon Sep 17 00:00:00 2001 From: Christian Weilbach Date: Thu, 30 Jul 2026 02:14:34 -0700 Subject: [PATCH 10/13] fix(datahike): pin the module's own datahike dep to the release MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The module deps.edn still carried :local/root "../../../datahike" and a comment saying the fix was unreleased, while the root deps.edn had already moved to 0.8.1759. A consumer building this module alone would have resolved a sibling checkout on whatever branch it happened to sit on — exactly the failure mode the comment warned about. --- modules/eacl-datahike/deps.edn | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/modules/eacl-datahike/deps.edn b/modules/eacl-datahike/deps.edn index 8584f18dc..4b2fb11e3 100644 --- a/modules/eacl-datahike/deps.edn +++ b/modules/eacl-datahike/deps.edn @@ -1,11 +1,10 @@ {:paths ["src" "resources"] :deps {org.clojure/clojure {:mvn/version "1.12.0-alpha5"} cloudafrica/eacl {:local/root "../eacl"} - ;; Needs the composite-tuple fix (replikativ/datahike#921): without it EVERY - ;; relation and permission tuple silently fails to derive under - ;; :attribute-refs?, so every permission denies. Merged to datahike main but - ;; not yet tagged — switch to an :mvn/version once released. - org.replikativ/datahike {:local/root "../../../datahike"} + ;; 0.8.1759 is the first release carrying replikativ/datahike#921. Below it + ;; EVERY relation and permission tuple silently fails to derive under + ;; :attribute-refs? — and the tuples ARE the v7 engine, so every check denies. + org.replikativ/datahike {:mvn/version "0.8.1759"} org.clojure/tools.logging {:mvn/version "1.3.0"}} :aliases {:test {:extra-paths ["test"] :extra-deps {io.github.cognitect-labs/test-runner {:git/tag "v0.5.1" :git/sha "dfb30dd"}}} From a40df8045a9a2580c01a12e99ea6a5ee44332d55 Mon Sep 17 00:00:00 2001 From: Petrus Theron Date: Sat, 1 Aug 2026 14:43:18 +0200 Subject: [PATCH 11/13] fix(datahike): make the backend independently releasable --- modules/eacl-datahike/build.clj | 41 ++++++++++++++++++++ modules/eacl-datahike/deps.edn | 15 ++++--- modules/eacl/src/eacl/engine/indexed.cljc | 2 +- modules/eacl/test/eacl/contract_support.cljc | 18 +++++++++ 4 files changed, 69 insertions(+), 7 deletions(-) create mode 100644 modules/eacl-datahike/build.clj diff --git a/modules/eacl-datahike/build.clj b/modules/eacl-datahike/build.clj new file mode 100644 index 000000000..090a9df15 --- /dev/null +++ b/modules/eacl-datahike/build.clj @@ -0,0 +1,41 @@ +(ns build + (:require [clojure.java.io :as io] + [clojure.tools.build.api :as b])) + +(def module-dir + (if (.exists (io/file "modules/eacl-datahike/src")) + "modules/eacl-datahike" + ".")) + +(def lib 'cloudafrica/eacl-datahike) +(def version "0.0.1-SNAPSHOT") +(def class-dir (str module-dir "/target/classes")) +(def jar-file (format "%s/target/%s-%s.jar" module-dir (name lib) version)) +(def pom-basis + {:libs {'org.clojure/clojure {:mvn/version "1.11.4"} + 'cloudafrica/eacl {:mvn/version version} + 'com.rpl/specter {:mvn/version "1.1.4"} + 'org.replikativ/datahike {:mvn/version "0.8.1759"}}}) + +(defn clean [_] + (b/delete {:path (str module-dir "/target")})) + +(defn jar [_] + (clean nil) + (b/write-pom {:class-dir class-dir + :lib lib + :version version + :basis pom-basis + :src-dirs [(str module-dir "/src")]}) + (b/copy-dir {:src-dirs [(str module-dir "/src")] + :target-dir class-dir}) + (b/jar {:class-dir class-dir + :jar-file jar-file})) + +(defn install [_] + (jar nil) + (b/install {:class-dir class-dir + :jar-file jar-file + :lib lib + :version version + :basis pom-basis})) diff --git a/modules/eacl-datahike/deps.edn b/modules/eacl-datahike/deps.edn index 4b2fb11e3..bcae38743 100644 --- a/modules/eacl-datahike/deps.edn +++ b/modules/eacl-datahike/deps.edn @@ -1,13 +1,16 @@ -{:paths ["src" "resources"] - :deps {org.clojure/clojure {:mvn/version "1.12.0-alpha5"} +{:paths ["src"] + :deps {org.clojure/clojure {:mvn/version "1.11.4"} cloudafrica/eacl {:local/root "../eacl"} + com.rpl/specter {:mvn/version "1.1.4"} ;; 0.8.1759 is the first release carrying replikativ/datahike#921. Below it ;; EVERY relation and permission tuple silently fails to derive under ;; :attribute-refs? — and the tuples ARE the v7 engine, so every check denies. - org.replikativ/datahike {:mvn/version "0.8.1759"} - org.clojure/tools.logging {:mvn/version "1.3.0"}} - :aliases {:test {:extra-paths ["test"] + org.replikativ/datahike {:mvn/version "0.8.1759"}} + :aliases {:build {:extra-paths ["."] + :ns-default build + :extra-deps {io.github.clojure/tools.build {:mvn/version "0.10.8"}}} + :test {:extra-paths ["test" "../eacl/test"] :extra-deps {io.github.cognitect-labs/test-runner {:git/tag "v0.5.1" :git/sha "dfb30dd"}}} - :nrepl {:extra-paths ["test"] + :nrepl {:extra-paths ["test" "../eacl/test"] :extra-deps {nrepl/nrepl {:mvn/version "1.3.1"}} :main-opts ["-m" "nrepl.cmdline"]}}} diff --git a/modules/eacl/src/eacl/engine/indexed.cljc b/modules/eacl/src/eacl/engine/indexed.cljc index 0f09ad4ec..8ad73d296 100644 --- a/modules/eacl/src/eacl/engine/indexed.cljc +++ b/modules/eacl/src/eacl/engine/indexed.cljc @@ -630,7 +630,7 @@ (take limit results) results) result-type (result-type-fn query) - items (doall (map #(spice-object result-type %) limited-results)) + items (into [] (map #(spice-object result-type %)) limited-results) last-id (:id (last items))] {:data items ;; The legacy limit/cursor API signals exhaustion with no cursor on an diff --git a/modules/eacl/test/eacl/contract_support.cljc b/modules/eacl/test/eacl/contract_support.cljc index cca6cce1f..13831ca13 100644 --- a/modules/eacl/test/eacl/contract_support.cljc +++ b/modules/eacl/test/eacl/contract_support.cljc @@ -62,6 +62,24 @@ (is (false? (eacl/can? client (->user "user-2") :reboot (->server "server-1")))) (is (false? (eacl/can? client (->user "missing-user") :reboot (->server "server-1"))))) + (testing "unknown lookup anchors return canonical empty pages" + (let [forward-query {:subject (->user "missing-user") + :permission :view + :resource/type :server + :limit 100} + reverse-query {:resource (->server "missing-server") + :permission :view + :subject/type :user + :limit 100}] + (is (= {:data [] :cursor nil} + (eacl/lookup-resources client forward-query))) + (is (= {:count 0 :limit 100 :cursor nil} + (eacl/count-resources client forward-query))) + (is (= {:data [] :cursor nil} + (eacl/lookup-subjects client reverse-query))) + (is (= {:count 0 :limit 100 :cursor nil} + (eacl/count-subjects client reverse-query))))) + (testing "lookup-resources and count-resources share cursor semantics" (let [{page1-data :data page1-cursor :cursor} (eacl/lookup-resources client {:subject (->user "user-1") From 5b420db6fa81e2bd4ff7585829edefeb1a8ecec8 Mon Sep 17 00:00:00 2001 From: Petrus Theron Date: Sat, 1 Aug 2026 18:17:16 +0200 Subject: [PATCH 12/13] fix(datahike): preserve exhausted cursor frontiers --- modules/eacl-datahike/src/eacl/datahike/core.clj | 16 ++++++++++++++-- 1 file changed, 14 insertions(+), 2 deletions(-) diff --git a/modules/eacl-datahike/src/eacl/datahike/core.clj b/modules/eacl-datahike/src/eacl/datahike/core.clj index 23eaffa34..530893c83 100644 --- a/modules/eacl-datahike/src/eacl/datahike/core.clj +++ b/modules/eacl-datahike/src/eacl/datahike/core.clj @@ -15,6 +15,12 @@ (def cursor->token cursor/cursor->token) (def token->cursor cursor/token->cursor) +(defn- transform-frontier + [f frontier] + (if (= :exhausted frontier) + frontier + (f frontier))) + (defn default-internal-cursor->spice [db {:keys [entid->object-id]} cursor] (when cursor @@ -30,7 +36,10 @@ (:p cursor) (update :p (fn [p] (into {} - (map (fn [[k v]] [k (entid->object-id db v)])) + (map (fn [[k v]] + [k (transform-frontier + #(entid->object-id db %) + v)])) p)))) :else (cond @@ -52,7 +61,10 @@ (:p cursor) (update :p (fn [p] (into {} - (map (fn [[k v]] [k (object-id->entid db v)])) + (map (fn [[k v]] + [k (transform-frontier + #(object-id->entid db %) + v)])) p)))) :else (cond From e8cee0dc889e7d7ca6d20e17665a6866dffbeca6 Mon Sep 17 00:00:00 2001 From: Petrus Theron Date: Sat, 1 Aug 2026 18:17:28 +0200 Subject: [PATCH 13/13] test(datahike): cover exhausted cursor resumption --- .../test/eacl/datahike/backend_test.clj | 24 +++++++++++++++++++ 1 file changed, 24 insertions(+) diff --git a/modules/eacl-datahike/test/eacl/datahike/backend_test.clj b/modules/eacl-datahike/test/eacl/datahike/backend_test.clj index dfce9f26e..13a354385 100644 --- a/modules/eacl-datahike/test/eacl/datahike/backend_test.clj +++ b/modules/eacl-datahike/test/eacl/datahike/backend_test.clj @@ -146,3 +146,27 @@ "the owner path is gone from the schema, so the cached answer must not stand") (is (true? (eacl/can? client (eacl/spice-object :user "super-user") :reboot server-1)) "and the surviving path still resolves"))))) + +(deftest exhausted-path-frontiers-survive-cursor-coercion + (doseq [[label config] modes] + (testing label + (let [[_ client] (seeded-conn config) + query {:subject (contract/->user "user-1") + :permission :admin + :resource/type :account + :limit 1} + page (eacl/lookup-resources client query) + cursor (datahike/token->cursor (:cursor page))] + (is (contains? (set (vals (:p cursor))) :exhausted) + "an exhausted path must remain exhausted in the public cursor") + (let [calls (atom 0) + original impl/subject->resources] + (with-redefs [impl/subject->resources + (fn [& args] + (swap! calls inc) + (apply original args))] + (eacl/lookup-resources + client + (assoc query :cursor (:cursor page)))) + (is (= 1 @calls) + "only the live path is scanned when the page resumes"))))))