diff --git a/.devcontainer/.env.example b/.devcontainer/.env.example new file mode 100644 index 0000000..993ad26 --- /dev/null +++ b/.devcontainer/.env.example @@ -0,0 +1,19 @@ +# Copy this file to .env and fill in values. +# NEVER commit .env — it contains secrets. + +### GIT ### +# GitHub personal access token used for git operations inside the container (replaces ~/.ssh host mount) +# Required permission: `repo` (classic PAT) or equivalent fine-grained repository permissions. +GIT_REMOTE_USERNAME=github_username +GIT_REMOTE_PAT=github_pat_REPLACE_ME + +# Git identity inside the container (replaces ~/.gitconfig host mount) +GIT_AUTHOR_NAME=Firstname Lastname +GIT_AUTHOR_EMAIL=firstname.lastname@econ.uzh.ch + +# opam Package Manager +OPAMSOLVERTIMEOUT=180 +OPAMWORKINGDIR=true + +### PROJECT SPECIFIC ### +VERSION=dev diff --git a/.devcontainer/Dockerfile b/.devcontainer/Dockerfile deleted file mode 100644 index 929b91c..0000000 --- a/.devcontainer/Dockerfile +++ /dev/null @@ -1,61 +0,0 @@ -FROM node:lts AS node -FROM hadolint/hadolint:latest-alpine AS hadolint -FROM ocaml/opam:debian-12-ocaml-5.3 - -USER root - -# copy node from node container and link commands -COPY --from=node /usr/local/lib/node_modules /usr/local/lib/node_modules -COPY --from=node /usr/local/bin/node /usr/local/bin/node -COPY --from=node /opt /opt -RUN ln -s /usr/local/lib/node_modules/npm/bin/npm-cli.js /usr/local/bin/npm \ - && ln -s /usr/local/lib/node_modules/npm/bin/npx-cli.js /usr/local/bin/npx \ - && ln -s /usr/local/bin/node /usr/local/bin/nodejs \ - && ln -s /opt/yarn-v*/bin/yarn /usr/local/bin/yarn \ - && ln -s /opt/yarn-v*/bin/yarnpkg /usr/local/bin/yarnpkg - -# copy hadolint -COPY --from=hadolint /bin/hadolint /bin/hadolint - -# Avoid warnings by switching to noninteractive -ENV DEBIAN_FRONTEND=noninteractive SIHL_ENV=development - -# install packages -# hadolint ignore=DL3008 -RUN apt-get update --allow-releaseinfo-change -q \ - && apt-get install -yqq --no-install-recommends \ - inotify-tools \ - libev-dev \ - libgmp-dev \ - libmariadb-dev \ - libssl-dev \ - m4 \ - pkg-config \ - wget \ - zsh \ - # - # cleanup installations - && apt-get autoremove -y \ - && apt-get clean all \ - && rm -rf /var/lib/apt/lists/* - -# add timezone -RUN ln -fs /usr/share/zoneinfo/Europe/Zurich /etc/localtime - -# WTF: https://github.com/mirage/ocaml-cohttp/issues/675 -RUN bash -c 'echo "http 80/tcp www # WorldWideWeb HTTP" >> /etc/services' \ - && bash -c 'echo "https 443/tcp www # WorldWideWeb HTTPS" >> /etc/services' - -# link opam version -RUN ln -fs /usr/bin/opam-2.3 /usr/bin/opam - -USER opam - -# install oh-my-zsh -SHELL ["/bin/bash", "-o", "pipefail", "-c"] -RUN wget https://github.com/robbyrussell/oh-my-zsh/raw/master/tools/install.sh -q -O - | zsh \ - && cp ~/.oh-my-zsh/templates/zshrc.zsh-template ~/.zshrc \ - && sed -i "/^plugins=/c\plugins=(git dotenv)" ~/.zshrc - -# Switch back to dialog for any ad-hoc use of apt-get -ENV DEBIAN_FRONTEND=dialog diff --git a/.devcontainer/README.md b/.devcontainer/README.md deleted file mode 100644 index 945b996..0000000 --- a/.devcontainer/README.md +++ /dev/null @@ -1,41 +0,0 @@ -# Development with DevContainer - -[Back to Main README](../README.md) - -## VSCode setup - -### Requirements - -This project is setup to run in a DevContainer. Ensure requirements to run in a DevContainer: - -1. [Git](https://gitlab.uzh.ch/econ/it/engineering-public/-/wikis/git) installed -1. Source Tree for GitLab setup (see [Install user interface](https://gitlab.uzh.ch/econ/it/engineering-public/-/wikis/git#install-user-interface) and [Configure GitLab for Source Tree](https://gitlab.uzh.ch/econ/it/engineering-public/-/wikis/git#configure-gitlab-for-source-tree)) -1. [Docker](/Technologies/Docker) installed -1. [Visual Studio Code](https://code.visualstudio.com/) (VS Code) installed -1. VS Code Extension [Remote Container](https://marketplace.visualstudio.com/items?itemName=ms-vscode-remote.remote-containers) installed - -Your SSH folder and Git config gets mapped to the container. You should be able to use SSH and Git inside the -container. Please ensure `~/.gitconfig` doesn't contain absolute paths (you may use the `~` profile prefix, i.e. -`excludesfile = ~/.gitignore_global`). **Please note:** You probably have to update Sourcetree settings. In its -settings "General" tab uncheck "Allow Sourcetree to modify your global Mercurial and Git configuration files". - -### Start DevContainer - -Click on the icon similar to "><" in the bottom left corner and select `Remote-Containers: Reopen in Container`. -If any changes were made to files in `.devcontainer` folder the Container should be rebuilt (`Remote-Containers: Rebuild Container`) - -> **NOTE**: When the setup is fully installed, select `View` -> `Command Palette...` and run the command `OCaml: Restart Language Server` - -## Build and run or start project - -[Back to Main README](../README.md) - -## Database View - -There is an `Adminer` container added to the development package. To be able to use it, follow these few steps: - -1. Uncomment its line in the `.devcontainer/devcontainer.json` under `runServices` -1. Use `Remote-Containers: Rebuild Container` that it will also create and startup the `Adminer` container -1. Open your web browser and open `localhost:8080` -1. Use the _development_ credentials defined for the development database in your `.env` file - (default: `user: root`, `password: `, `host: database`, `database: development` ) diff --git a/.devcontainer/devcontainer-lock.json b/.devcontainer/devcontainer-lock.json new file mode 100644 index 0000000..721cf86 --- /dev/null +++ b/.devcontainer/devcontainer-lock.json @@ -0,0 +1,34 @@ +{ + "features": { + "cr.gitlab.uzh.ch/econ/it/devcontainer-features/econ-common:1": { + "version": "1.3.0", + "resolved": "cr.gitlab.uzh.ch/econ/it/devcontainer-features/econ-common@sha256:bcdb1ae6f36e87194f5931a0a0b499302f1cfd66975ce273a8bf7a27aae3bd85", + "integrity": "sha256:bcdb1ae6f36e87194f5931a0a0b499302f1cfd66975ce273a8bf7a27aae3bd85" + }, + "cr.gitlab.uzh.ch/econ/it/devcontainer-features/econ-git-credentials:1": { + "version": "1.0.0", + "resolved": "cr.gitlab.uzh.ch/econ/it/devcontainer-features/econ-git-credentials@sha256:1550cbc5cacd684eb8e381bbe633a941097106766ceab4392dfb1e3b4ec2318d", + "integrity": "sha256:1550cbc5cacd684eb8e381bbe633a941097106766ceab4392dfb1e3b4ec2318d" + }, + "cr.gitlab.uzh.ch/econ/it/devcontainer-features/econ-hadolint:1": { + "version": "1.1.0", + "resolved": "cr.gitlab.uzh.ch/econ/it/devcontainer-features/econ-hadolint@sha256:fac537456f661a25cdd4a418b468810ac3395e553f6c3d791387201eab28d113", + "integrity": "sha256:fac537456f661a25cdd4a418b468810ac3395e553f6c3d791387201eab28d113" + }, + "cr.gitlab.uzh.ch/econ/it/devcontainer-features/econ-ocaml:1": { + "version": "1.0.0", + "resolved": "cr.gitlab.uzh.ch/econ/it/devcontainer-features/econ-ocaml@sha256:1b2f40ff0fd48ad43255e34f78e93c041fb85a4673c71736b8e7a06657785d0d", + "integrity": "sha256:1b2f40ff0fd48ad43255e34f78e93c041fb85a4673c71736b8e7a06657785d0d" + }, + "cr.gitlab.uzh.ch/econ/it/devcontainer-features/econ-version:2": { + "version": "2.0.0", + "resolved": "cr.gitlab.uzh.ch/econ/it/devcontainer-features/econ-version@sha256:c3168d4bfa246b0e0780f07571cb1bb9d98d60dde78cc1a8e9868ceb0d9a7ab7", + "integrity": "sha256:c3168d4bfa246b0e0780f07571cb1bb9d98d60dde78cc1a8e9868ceb0d9a7ab7" + }, + "cr.gitlab.uzh.ch/econ/it/devcontainer-features/econ-wait-for-databases:1": { + "version": "1.0.0", + "resolved": "cr.gitlab.uzh.ch/econ/it/devcontainer-features/econ-wait-for-databases@sha256:3797759d376f94f29c56d6319418b8db1e3913b0e4793febcb2eef6122bdd69e", + "integrity": "sha256:3797759d376f94f29c56d6319418b8db1e3913b0e4793febcb2eef6122bdd69e" + } + } +} diff --git a/.devcontainer/devcontainer.json b/.devcontainer/devcontainer.json index d4f368e..9da5d31 100644 --- a/.devcontainer/devcontainer.json +++ b/.devcontainer/devcontainer.json @@ -1,6 +1,3 @@ -// For format details, see https://aka.ms/vscode-remote/devcontainer.json or the definition README at -// https://github.com/microsoft/vscode-dev-containers/tree/master/containers/python-3 or the -// devcontainer docu https://code.visualstudio.com/docs/remote/containers#_devcontainerjson-reference { "name": "Guardian dev", "dockerComposeFile": "./docker-compose.yml", @@ -8,45 +5,35 @@ "runServices": [ "dev", "database" - // "adminer" // uncomment if adminer should run to see the database + // "adminer" ], "workspaceFolder": "/workspace", - "remoteEnv": { - "VERSION": "dev", - "OPAMWORKINGDIR": "true", - "OPAMSOLVERTIMEOUT": "180" + "features": { + "cr.gitlab.uzh.ch/econ/it/devcontainer-features/econ-common:1": {}, + "cr.gitlab.uzh.ch/econ/it/devcontainer-features/econ-git-credentials:1": { + "git_remote_host": "github.com" + }, + "cr.gitlab.uzh.ch/econ/it/devcontainer-features/econ-hadolint:1": {}, + "cr.gitlab.uzh.ch/econ/it/devcontainer-features/econ-wait-for-databases:1": { + "databases": "dev/test" + }, + "cr.gitlab.uzh.ch/econ/it/devcontainer-features/econ-ocaml:1": { + "opam_version": "2.3", + "folders": [ + "/workspace/_build", + "/home/opam/.cache" + ] + }, + "cr.gitlab.uzh.ch/econ/it/devcontainer-features/econ-version:2": { + "version_source": "guardian.opam::^version: \\\"([^\\\"]+)\\\"", + "ocaml": true + } }, - "postCreateCommand": ".devcontainer/wait-for-database.sh test .devcontainer/postCreate.sh", - // Use 'settings' to set *default* container specific settings.json values on container create. - // You can edit these settings after create using File > Preferences > Settings > Remote. + "postCreateCommand": "wait-for-databases make deps", "customizations": { "vscode": { - "settings": { - "terminal.integrated.profiles.linux": { - "zsh": { - "path": "/bin/zsh" - } - }, - "terminal.integrated.defaultProfile.linux": "zsh", - "editor.formatOnSave": true, - "files.associations": { - "*.ml": "ocaml", - "*.mli": "ocaml" - }, - "git.mergeEditor": false, - "ocaml.sandbox": { - "kind": "global" - } - }, - // Add the IDs of extensions you want installed when the container is created in the array below. "extensions": [ - "donjayamanne.githistory", - "eamodio.gitlens", - "exiasr.hadolint", - "irongeek.vscode-env", - "ocamllabs.ocaml-platform", - "DavidAnson.vscode-markdownlint", - "ms-vscode.makefile-tools" + "Anthropic.claude-code" ] } } diff --git a/.devcontainer/docker-compose.yml b/.devcontainer/docker-compose.yml index 38d6dbb..8f68d85 100644 --- a/.devcontainer/docker-compose.yml +++ b/.devcontainer/docker-compose.yml @@ -1,24 +1,24 @@ services: dev: container_name: guardian_dev - build: - context: . - dockerfile: Dockerfile + image: ocaml/opam:debian-12-ocaml-5.3 + env_file: [.env] volumes: # default user is "opam" - ..:/workspace:cached - opam:/home/opam/.opam:cached - build:/workspace/_build:cached - - ${HOME}/.gitconfig:/home/opam/.gitconfig:ro - depends_on: [ database ] - ports: [ 3020:3000 ] - command: /workspace/.devcontainer/wait-for-database.sh test sleep infinity + - db:/databases/dev/:ro + - ${HOME}/.claude:/home/opam/.claude + depends_on: [database] + ports: [3020:3000] + command: sleep infinity database: container_name: guardian_database image: mariadb:10.6.3 command: --max_allowed_packet=629145600 - ports: [ 3320:3306 ] + ports: [3320:3306] environment: - TZ=Europe/Zurich - MYSQL_ALLOW_EMPTY_PASSWORD='yes' @@ -26,15 +26,16 @@ services: - MYSQL_DATABASE=development - MYSQL_USER=root volumes: - - ./data/db:/var/lib/mysql + - db:/var/lib/mysql - ./init:/docker-entrypoint-initdb.d/:ro adminer: image: adminer:standalone restart: always - ports: [ 8080:8080 ] - depends_on: [ database ] + ports: [8080:8080] + depends_on: [database] volumes: opam: build: + db: diff --git a/.devcontainer/postCreate.sh b/.devcontainer/postCreate.sh deleted file mode 100755 index 799698d..0000000 --- a/.devcontainer/postCreate.sh +++ /dev/null @@ -1,14 +0,0 @@ -# ocaml/opam post create script - -sudo chown -R opam: _build - -opam init -a --shell=zsh - -# update default ocaml remote - make sure that opam finds latest package versions -# (e.g. otherwise alcotest latest version is 1.1.0 instead of 1.2.1) -opam remote remove --all default -opam repository add default --all-switches --set-default https://opam.ocaml.org - -opam install --with-test --with-doc --deps-only -y . - -make deps diff --git a/.devcontainer/wait-for-database.sh b/.devcontainer/wait-for-database.sh deleted file mode 100755 index a46550a..0000000 --- a/.devcontainer/wait-for-database.sh +++ /dev/null @@ -1,16 +0,0 @@ -#!/bin/sh - -set -e - -database="$1" -shift -cmd="$@" - -# checking if database folder exists instead of connecting to mysql which would require to install mysql client in container -until [ -d /workspace/.devcontainer/data/db/$database ]; do - echo "MySQL database not yet created - sleeping" - sleep 1 -done - -echo "MySQL database created - executing command" -exec $cmd diff --git a/.gitignore b/.gitignore index 271f0c5..09492b5 100644 --- a/.gitignore +++ b/.gitignore @@ -1,4 +1,4 @@ _build/ -.devcontainer/data .env* +!.env.example .DS_Store diff --git a/CHANGELOG.md b/CHANGELOG.md index f484072..0bc502a 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,6 +4,27 @@ The format is based on [Keep a Changelog](http://keepachangelog.com/) and this p ## [unreleased](https://github.com/uzh/guardian/tree/HEAD) +### Added + +- Cache for target uuid to model resolution, so cached validations no longer require a database round trip +- Indexes on `role` for `guardian_actor_roles` and `guardian_actor_role_targets` + +### Changed + +- Cache invalidation for a single actor now bumps a per-actor generation (and a global epoch for full clears) instead of scanning the whole cache; keys are snapshotted when a validation starts so an invalidation that races an in-flight validation is not lost +- Role permission changes invalidate the cache in one step instead of querying and clearing all affected actors +- `PermissionOnTarget.remove_duplicates` runs in linearithmic instead of quadratic time +- `ActorRole.find_by_actor` and `find_by_target` use `UNION ALL`; validation queries use inner joins where applicable +- `clean` and `delete` clear the caches + +### Removed + +- Redundant single-column indexes that duplicated unique-constraint prefixes + +### Fixed + +- Version prefix of sexp dependency + ## [0.4.0](https://github.com/uzh/guardian/tree/0.4.0) - 2026-04-07 ### Added diff --git a/README.md b/README.md index ae40bda..758e286 100644 --- a/README.md +++ b/README.md @@ -70,7 +70,23 @@ Example usage: ## Development -A guide how to setup the project with devcontainers can be found in [this README](./.devcontainer/README.md). +This project runs in a DevContainer. All credentials are passed via a local `.env` file — no host SSH keys required. + +1. Follow the general DevContainer instructions in the [Engineering Wiki](https://gitlab.uzh.ch/econ/it/engineering/-/wikis/2_best-practices/DevContainer). +1. Copy the env template and fill in the values: `cp .devcontainer/.env.example .devcontainer/.env` +1. Click the `><` icon in the bottom-left corner of VS Code and select **Reopen in Container**. + +> **NOTE**: When the setup is fully installed, select `View` -> `Command Palette...` and run the command `OCaml: Restart Language Server` + +### Database View + +There is an `Adminer` container added to the development package. To be able to use it, follow these few steps: + +1. Uncomment its line in the `.devcontainer/devcontainer.json` under `runServices` +1. Use `Remote-Containers: Rebuild Container` that it will also create and startup the `Adminer` container +1. Open your web browser and open `localhost:8080` +1. Use the _development_ credentials defined for the development database in your `.env` file + (default: `user: root`, `password: `, `host: database`, `database: development` ) ### Commands diff --git a/backend/caqti_encoders.ml b/backend/caqti_encoders.ml index e7e9101..9b80284 100644 --- a/backend/caqti_encoders.ml +++ b/backend/caqti_encoders.ml @@ -36,7 +36,7 @@ let custom = fun ~encode ~decode schema -> let typ = Schema.make_type schema in - let encode data = encode data |> Result.map Data.make_value in + let encode data = encode data |> CCResult.map Data.make_value in Caqti_type.custom ~encode ~decode typ ;; @@ -44,7 +44,7 @@ let custom_ok : type a b. encode:(b -> a Data.t) -> decode:(a -> b) -> a Schema.t -> b Caqti_type.t = - let open CCFun in + let open CCFun.Infix in fun ~encode ~decode schema -> let typ = Schema.make_type schema in let encode = CCResult.(encode %> return %> map Data.make_value) in diff --git a/backend/database_pools.ml b/backend/database_pools.ml index 310289a..4829880 100644 --- a/backend/database_pools.ml +++ b/backend/database_pools.ml @@ -97,7 +97,7 @@ module Make (Config : ConfigSig) = struct module Hashtbl = CCHashtbl.Make (CCString) let pools : Pool.t Hashtbl.t = - Hashtbl.create (max 1 Config.expected_databases) + Hashtbl.create (CCInt.max 1 Config.expected_databases) ;; let add = Hashtbl.add pools @@ -273,7 +273,6 @@ module Make (Config : ConfigSig) = struct ;; let exec_each connection = - let open CCFun.Infix in Lwt_list.map_s (fun request -> request connection) %> Lwt.map CCResult.flatten_l %> Lwt_result.map (fun (_ : unit list) -> ()) diff --git a/backend/dune b/backend/dune index bc71729..75a0268 100644 --- a/backend/dune +++ b/backend/dune @@ -3,6 +3,7 @@ (name Guardian_backend) (libraries caqti + caqti.classic caqti-driver-mariadb caqti-lwt caqti-lwt.unix diff --git a/backend/mariadb_backend.ml b/backend/mariadb_backend.ml index c83064f..1a3edba 100644 --- a/backend/mariadb_backend.ml +++ b/backend/mariadb_backend.ml @@ -1,4 +1,4 @@ -open CCFun +open CCFun.Infix open Lwt.Infix open Caqti_request.Infix @@ -254,11 +254,14 @@ struct ;; (* Flat LRU cache keyed by the full (actor, pool, any_id, permission, - target_uuid, model) tuple. A total capacity cap means entries are - evicted in LRU order rather than growing without bound. *) + target_uuid, model) tuple plus a global epoch and a per-actor + generation number. A total capacity cap means entries are evicted in + LRU order rather than growing without bound. *) type cache_key = - { actor : string + { epoch : int + ; actor : string + ; generation : int ; pool : string option ; any_id : bool ; permission : Guard.Permission.t @@ -270,15 +273,17 @@ struct type t = cache_key let equal a b = - String.equal a.actor b.actor - && CCOption.equal String.equal a.pool b.pool - && Bool.equal a.any_id b.any_id + CCInt.equal a.epoch b.epoch + && CCString.equal a.actor b.actor + && CCInt.equal a.generation b.generation + && CCOption.equal CCString.equal a.pool b.pool + && CCBool.equal a.any_id b.any_id && Guard.Permission.equal a.permission b.permission && CCOption.equal Guard.Uuid.Target.equal a.target_uuid b.target_uuid && CCOption.equal TargetModel.equal a.model b.model ;; - let hash = Hashtbl.hash + let hash = CCHash.poly end module CacheValue = struct @@ -293,32 +298,61 @@ struct actors. Evicts the least-recently-used entry when the limit is hit. *) let capacity = 4096 let _cache = ref (LruCache.create capacity) - let clear () = _cache := LruCache.create capacity + + (* [epoch] scopes every key at once: bumping it makes all previously + stored keys unreachable. [generations] scopes a single actor's keys. + Both are snapshotted into the key by [make_key] and therefore captured + when a validation *starts*; if an invalidation races an in-flight + validation, the result is stored under the (now stale) snapshot and is + unreachable to later lookups instead of overwriting the invalidation. + [max_tracked_actors] keeps the generations table from growing with + every actor ever invalidated. *) + let epoch = ref 0 + + module Generations = CCHashtbl.Make (CCString) + + let generations : int Generations.t = Generations.create 256 + let max_tracked_actors = 100_000 + + (* Bumping [epoch] invalidates every key (including snapshots taken by + in-flight validations), so resetting [generations] back to 0 here is + safe: no surviving entry can share the new epoch. *) + let clear () = + incr epoch; + _cache := LruCache.create capacity; + Generations.reset generations + ;; + + let generation actor = Generations.get_or generations actor ~default:0 (** Remove all cached entries for a single actor. Used when that actor's roles or direct permissions change. *) let clear_actor uuid = - let actor_str = Guard.Uuid.Actor.to_string uuid in - let to_remove = - LruCache.fold - (fun k _ acc -> - if String.equal k.actor actor_str then k :: acc else acc) - [] - !_cache - in - List.iter (fun k -> LruCache.remove k !_cache) to_remove + let actor = Guard.Uuid.Actor.to_string uuid in + if + Generations.length generations >= max_tracked_actors + && not (Generations.mem generations actor) + then clear () + else Generations.incr generations actor + ;; + + let make_key ctx any_id actor_uuid permission target_uuid model = + let actor = Guard.Uuid.Actor.to_string actor_uuid in + { epoch = !epoch + ; actor + ; generation = generation actor + ; pool = pool_of_ctx ctx + ; any_id + ; permission + ; target_uuid + ; model + } ;; - let find ctx any_id actor_uuid permission target_uuid model = - let key = - { actor = Guard.Uuid.Actor.to_string actor_uuid - ; pool = pool_of_ctx ctx - ; any_id - ; permission - ; target_uuid - ; model - } - in + (* [find] and [store] take a key precomputed by [make_key] so a single + validation snapshots the epoch/generation once and reuses it for both + the lookup and the store. *) + let find key = match LruCache.find key !_cache with | Some _ as v -> LruCache.promote key !_cache; @@ -326,21 +360,82 @@ struct | None -> None ;; - let store ctx any_id actor_uuid permission target_uuid model result = - let key = - { actor = Guard.Uuid.Actor.to_string actor_uuid - ; pool = pool_of_ctx ctx - ; any_id - ; permission - ; target_uuid - ; model - } - in + let store key result = LruCache.add key result !_cache; LruCache.trim !_cache ;; end + (* Caches the target uuid -> model resolution used by [validate], so a + validation-cache hit does not still cost a database round trip. + Invalidated by [Target.promote] and by [clear_cache]/[clean]/[delete]. *) + module ModelCache = struct + type model_key = + { epoch : int + ; pool : string option + ; target : string + } + + module CacheKey = struct + type t = model_key + + let equal a b = + let open CCString in + CCInt.equal a.epoch b.epoch + && CCOption.equal equal a.pool b.pool + && equal a.target b.target + ;; + + let hash = CCHash.poly + end + + module CacheValue = struct + type t = TargetModel.t + + let weight _ = 1 + end + + module LruCache = Lru.M.Make (CacheKey) (CacheValue) + + let capacity = 4096 + let _cache = ref (LruCache.create capacity) + + (* [epoch] is snapshotted into the key when a resolution *starts*. + Bumping it (via [invalidate]/[clear]) makes every earlier key + unreachable, so a [promote] that races an in-flight resolution cannot + be overwritten by the stale model the resolution was still computing; + the stale entry ages out via LRU instead. *) + let epoch = ref 0 + let clear () = incr epoch + + let make_key ctx uuid = + { epoch = !epoch + ; pool = DBCache.pool_of_ctx ctx + ; target = Guard.Uuid.Target.to_string uuid + } + ;; + + let find key = + match LruCache.find key !_cache with + | Some _ as v -> + LruCache.promote key !_cache; + v + | None -> None + ;; + + let store key model = + LruCache.add key model !_cache; + LruCache.trim !_cache + ;; + + (* A promoted target changes model, so drop its cached resolution and bump + the epoch to also discard any in-flight resolution of the old model. *) + let invalidate ctx uuid = + LruCache.remove (make_key ctx uuid) !_cache; + incr epoch + ;; + end + include Guard.MakePersistence (struct type actor = Guard.Actor.t type actor_model = ActorModel.t @@ -356,7 +451,10 @@ struct type validation_set = Guard.ValidationSet.t module Repo = struct - let clear_cache = DBCache.clear + let clear_cache () = + DBCache.clear (); + ModelCache.clear () + ;; module Model = struct let role = Entity.Role.t @@ -433,7 +531,7 @@ struct FROM guardian_actor_role_targets AS role_targets WHERE role_targets.actor_uuid = %{sql_value_fragment "$1"} AND role_targets.mark_as_deleted IS NULL - UNION + UNION ALL SELECT %{sql_select_fragment "roles.actor_uuid"}, roles.role, NULL FROM guardian_actor_roles AS roles WHERE roles.actor_uuid = %{sql_value_fragment "$1"} @@ -456,7 +554,7 @@ struct WHERE role_targets.role = $1 AND role_targets.target_uuid = %{Entity.Uuid.sql_value_fragment "$2"} AND role_targets.mark_as_deleted IS NULL - UNION + UNION ALL SELECT %{sql_select_fragment "roles.actor_uuid"}, roles.role, NULL FROM guardian_actor_roles AS roles WHERE roles.role = $1 @@ -578,13 +676,12 @@ struct %{Uuid.sql_select_fragment "roles.target_uuid"} FROM guardian_actor_role_targets AS roles - LEFT JOIN guardian_role_permissions AS role_permissions + JOIN guardian_role_permissions AS role_permissions ON role_permissions.role = roles.role AND role_permissions.mark_as_deleted IS NULL WHERE roles.mark_as_deleted IS NULL AND roles.actor_uuid = %{Uuid.sql_value_fragment "$1"} - AND `permission` IS NOT null UNION SELECT role_permissions.permission, @@ -592,13 +689,12 @@ struct NULL FROM guardian_actor_roles AS roles - LEFT JOIN guardian_role_permissions AS role_permissions + JOIN guardian_role_permissions AS role_permissions ON role_permissions.role = roles.role AND role_permissions.mark_as_deleted IS NULL WHERE roles.mark_as_deleted IS NULL AND roles.actor_uuid = %{Uuid.sql_value_fragment "$1"} - AND `permission` IS NOT null UNION SELECT actor_permissions.permission, @@ -612,7 +708,6 @@ struct WHERE actor_permissions.actor_uuid = %{Uuid.sql_value_fragment "$1"} AND actor_permissions.mark_as_deleted IS NULL - AND `permission` IS NOT null |sql}] |> Uuid.Actor.t ->* PermissionOnTarget.t ;; @@ -649,27 +744,6 @@ struct |> Caqti_type.(t2 Uuid.Actor.t Model.role ->. unit) ;; - let find_all_actors_with_role_request = - [%string - {sql| - SELECT %{Entity.Uuid.sql_select_fragment "actor_uuid"} FROM ( - SELECT actor_uuid FROM guardian_actor_roles - WHERE role = ? AND mark_as_deleted IS NULL - UNION - SELECT actor_uuid FROM guardian_actor_role_targets - WHERE role = ? AND mark_as_deleted IS NULL - ) AS combined - |sql}] - |> Caqti_type.t2 Entity.Role.t Entity.Role.t ->* Entity.Uuid.Actor.t - ;; - - (** Find all actor UUIDs that have [role] assigned (globally or - per-target). Used to invalidate cache entries when a role - permission rule changes. *) - let find_all_actors_with_role ?ctx role = - Database.collect ?ctx find_all_actors_with_role_request (role, role) - ;; - let delete ?ctx role = let open Guard.ActorRole in let () = DBCache.clear_actor role.actor_uuid in @@ -734,13 +808,10 @@ struct ;; let insert ?ctx rp = - let open Lwt.Syntax in - let* actor_uuids = - ActorRole.find_all_actors_with_role - ?ctx - rp.Guard.RolePermission.role - in - List.iter DBCache.clear_actor actor_uuids; + (* A changed rule affects every actor holding the role; dropping + the bounded cache outright is cheaper than enumerating those + actors. *) + let () = DBCache.clear () in Database.exec ?ctx insert_request rp |> Lwt_result.ok ;; @@ -757,13 +828,8 @@ struct ;; let delete ?ctx rp = - let open Lwt.Syntax in - let* actor_uuids = - ActorRole.find_all_actors_with_role - ?ctx - rp.Guard.RolePermission.role - in - List.iter DBCache.clear_actor actor_uuids; + (* See [insert]: invalidate all actors at once. *) + let () = DBCache.clear () in Database.exec ?ctx delete_request rp |> Lwt_result.ok ;; end @@ -1017,7 +1083,10 @@ struct |> Caqti_type.(t2 Uuid.Target.t TargetModel.t ->. unit) ;; - let promote ?ctx = CCFun.curry (Database.exec ?ctx promote_request) + let promote ?ctx uuid model = + let () = ModelCache.invalidate ctx uuid in + Database.exec ?ctx promote_request (uuid, model) + ;; end module RoleAssignment = struct @@ -1097,7 +1166,7 @@ struct SELECT ( SELECT TRUE FROM guardian_actor_roles AS roles - LEFT JOIN guardian_role_permissions AS role_permissions + JOIN guardian_role_permissions AS role_permissions ON roles.role = role_permissions.role AND role_permissions.mark_as_deleted IS NULL WHERE roles.mark_as_deleted IS NULL @@ -1157,7 +1226,7 @@ struct ) OR ( SELECT TRUE FROM guardian_actor_role_targets AS role_targets - LEFT JOIN guardian_role_permissions AS role_permissions + JOIN guardian_role_permissions AS role_permissions ON role_targets.role = role_permissions.role AND role_permissions.mark_as_deleted IS NULL WHERE role_targets.mark_as_deleted IS NULL @@ -1210,7 +1279,7 @@ struct SELECT ( SELECT TRUE FROM guardian_actor_roles AS roles - LEFT JOIN guardian_role_permissions AS role_permissions + JOIN guardian_role_permissions AS role_permissions ON roles.role = role_permissions.role AND role_permissions.mark_as_deleted IS NULL WHERE roles.mark_as_deleted IS NULL @@ -1221,7 +1290,7 @@ struct ) OR ( SELECT TRUE FROM guardian_actor_role_targets AS role_targets - LEFT JOIN guardian_role_permissions AS role_permissions + JOIN guardian_role_permissions AS role_permissions ON role_targets.role = role_permissions.role AND role_permissions.mark_as_deleted IS NULL WHERE role_targets.mark_as_deleted IS NULL @@ -1287,11 +1356,20 @@ struct (* [run_and_cache cache_model query] checks the cache keyed by [cache_model], runs [query] on a miss, then stores the result under the same key. Callers must pass the fully-resolved model - so the key is stable and concrete. *) + so the key is stable and concrete. The key is snapshotted once, + before running [query], so an invalidation that races the query + cannot be overwritten by this (now stale) result. *) let run_and_cache cache_model query = - match - DBCache.find ctx any_id uuid permission target_uuid cache_model - with + let key = + DBCache.make_key + ctx + any_id + uuid + permission + target_uuid + cache_model + in + match DBCache.find key with | Some granted -> log_result granted; Lwt.return granted @@ -1300,16 +1378,7 @@ struct >|= fun result -> let granted = CCResult.is_ok result in log_result granted; - let () = - DBCache.store - ctx - any_id - uuid - permission - target_uuid - cache_model - granted - in + let () = DBCache.store key granted in granted in match any_id, target_uuid, model with @@ -1329,8 +1398,19 @@ struct | false, Some target_uuid, None -> (* Resolve the model up front so both the DB query and the cache key use the concrete model, preventing stale model=None entries - if the target's model later changes (e.g. via Target.promote). *) - Target.find_model ?ctx target_uuid + if the target's model later changes (e.g. via Target.promote). + The resolution itself is cached so a validation-cache hit does + not still cost a database round trip. The model-cache key is + snapshotted before the resolution query so a racing promote is + not overwritten by the stale model being resolved here. *) + let model_key = ModelCache.make_key ctx target_uuid in + (match ModelCache.find model_key with + | Some model -> Lwt.return_ok model + | None -> + Target.find_model ?ctx target_uuid + >|= CCResult.map (fun model -> + ModelCache.store model_key model; + model)) >>= (function | Error _ as e -> let granted = CCResult.is_ok e in @@ -1383,9 +1463,13 @@ struct ;; (** [clean ?ctx ()] runs clean on a specified context [?ctx] **) - let clean ?ctx () = find_clean () |> run_without_fk_checks ?ctx "Clean" + let clean ?ctx () = + let () = Repo.clear_cache () in + find_clean () |> run_without_fk_checks ?ctx "Clean" + ;; let delete ?ctx () = + let () = Repo.clear_cache () in Migrations.all_tables |> CCList.map (fun m -> m, Format.asprintf "DROP TABLE IF EXISTS %s" m) |> run_without_fk_checks ?ctx "Delete" diff --git a/backend/migrations.ml b/backend/migrations.ml index 4d3dd8b..e4741de 100644 --- a/backend/migrations.ml +++ b/backend/migrations.ml @@ -244,6 +244,45 @@ let remove_unused_mark_as_deleted_column = |sql} ;; +let add_role_index_to_actor_roles = + {sql| + CREATE INDEX IF NOT EXISTS guardian_actor_roles_role_index + ON guardian_actor_roles (role) + |sql} +;; + +let add_role_index_to_actor_role_targets = + {sql| + CREATE INDEX IF NOT EXISTS guardian_actor_role_targets_role_index + ON guardian_actor_role_targets (role) + |sql} +;; + +(* The following indexes duplicate the leftmost prefix of a UNIQUE constraint + (or of the column-level UNIQUE index on uuid) on the same table, adding + write and storage cost without enabling any additional query plan. The + remaining unique indexes also keep satisfying the foreign keys. *) + +let drop_redundant_actors_uuid_index = + {sql|DROP INDEX IF EXISTS guardian_actors_uuid_index ON guardian_actors|sql} +;; + +let drop_redundant_targets_uuid_index = + {sql|DROP INDEX IF EXISTS guardian_targets_uuid_index ON guardian_targets|sql} +;; + +let drop_redundant_actor_roles_actor_uuid_index = + {sql|DROP INDEX IF EXISTS guardian_actor_roles_actor_uuid_index ON guardian_actor_roles|sql} +;; + +let drop_redundant_actor_role_targets_actor_uuid_index = + {sql|DROP INDEX IF EXISTS guardian_actor_role_targets_actor_uuid_index ON guardian_actor_role_targets|sql} +;; + +let drop_redundant_actor_permissions_actor_uuid_index = + {sql|DROP INDEX IF EXISTS guardian_actor_permissions_actor_uuid_index ON guardian_actor_permissions|sql} +;; + let all_tables = [ "guardian_actors" ; "guardian_actor_roles" @@ -311,5 +350,26 @@ let all = ; ( "remove unused mark as deleted column" , "2024-01-26T15:00" , remove_unused_mark_as_deleted_column ) + ; ( "add role index to guardian actor roles table" + , "2026-07-09T14:00" + , add_role_index_to_actor_roles ) + ; ( "add role index to guardian actor role targets table" + , "2026-07-09T14:01" + , add_role_index_to_actor_role_targets ) + ; ( "drop redundant uuid index on guardian actors table" + , "2026-07-09T14:02" + , drop_redundant_actors_uuid_index ) + ; ( "drop redundant uuid index on guardian targets table" + , "2026-07-09T14:03" + , drop_redundant_targets_uuid_index ) + ; ( "drop redundant actor uuid index on guardian actor roles table" + , "2026-07-09T14:04" + , drop_redundant_actor_roles_actor_uuid_index ) + ; ( "drop redundant actor uuid index on guardian actor role targets table" + , "2026-07-09T14:05" + , drop_redundant_actor_role_targets_actor_uuid_index ) + ; ( "drop redundant actor uuid index on guardian actor permissions table" + , "2026-07-09T14:06" + , drop_redundant_actor_permissions_actor_uuid_index ) ] ;; diff --git a/dune-project b/dune-project index 15c3a38..31af628 100644 --- a/dune-project +++ b/dune-project @@ -35,11 +35,11 @@ (>= 1.9.1))) (alcotest-lwt :with-test) (caqti - (>= 2.2.4)) + (>= 2.3.0)) (caqti-driver-mariadb - (>= 2.0.1)) + (>= 2.3.0)) (caqti-lwt - (>= 2.0.1)) + (>= 2.3.0)) (containers (>= 3.6)) (containers-data @@ -69,7 +69,7 @@ (ppx_deriving_yojson (>= 3.6.1)) (ppx_sexp_conv - (>= 0.15.1)) + (>= v0.15.1)) ppx_string (result (>= 1.5)) diff --git a/guardian.opam b/guardian.opam index 38d30f6..dff149a 100644 --- a/guardian.opam +++ b/guardian.opam @@ -16,9 +16,9 @@ depends: [ "dune" {>= "2.9"} "alcotest" {with-test & >= "1.9.1"} "alcotest-lwt" {with-test} - "caqti" {>= "2.2.4"} - "caqti-driver-mariadb" {>= "2.0.1"} - "caqti-lwt" {>= "2.0.1"} + "caqti" {>= "2.3.0"} + "caqti-driver-mariadb" {>= "2.3.0"} + "caqti-lwt" {>= "2.3.0"} "containers" {>= "3.6"} "containers-data" {>= "3.6"} "dune-release" {with-dev-setup} @@ -34,7 +34,7 @@ depends: [ "odoc" {with-doc} "ppx_deriving" {>= "5.2.1"} "ppx_deriving_yojson" {>= "3.6.1"} - "ppx_sexp_conv" {>= "0.15.1"} + "ppx_sexp_conv" {>= "v0.15.1"} "ppx_string" "result" {>= "1.5"} "sexplib0" diff --git a/lib/dune b/lib/dune index 29b0dd2..df72afc 100644 --- a/lib/dune +++ b/lib/dune @@ -2,7 +2,16 @@ (public_name guardian) (name guardian) (wrapped true) - (libraries caqti containers containers-data logs lwt result sexplib0 uuidm) + (libraries + caqti + caqti.classic + containers + containers-data + logs + lwt + result + sexplib0 + uuidm) (preprocess (pps lwt_ppx diff --git a/lib/guardian_entity.ml b/lib/guardian_entity.ml index e106eea..fa88be7 100644 --- a/lib/guardian_entity.ml +++ b/lib/guardian_entity.ml @@ -139,6 +139,27 @@ struct ;; let remove_duplicates (perms : t list) : t list = + let module PotSet = CCSet.Make (struct + type nonrec t = t + + let compare = compare + end) + in + (* Membership indexes over the whole input — grants without a target + uuid and per-uuid Manage grants — so each element is judged in + O(log n) instead of rescanning the list. *) + let model_wide, manage_on_uuid = + CCList.fold_left + (fun (model_wide, manage_on_uuid) + ({ permission; target_uuid; _ } as perm) -> + match target_uuid with + | None -> PotSet.add perm model_wide, manage_on_uuid + | Some _ when Permission.(equal Manage permission) -> + model_wide, PotSet.add perm manage_on_uuid + | Some _ -> model_wide, manage_on_uuid) + (PotSet.empty, PotSet.empty) + perms + in CCList.fold_left (fun init ({ permission; model; target_uuid } as permission_on_target) -> @@ -148,13 +169,16 @@ struct permission_on_target in let model_permission () = - let in_list perm = - CCList.mem ~eq:equal (of_tuple (perm, model, None)) perms + let in_index perm = + PotSet.mem (of_tuple (perm, model, None)) model_wide in - in_list permission || in_list Permission.Manage + in_index permission || in_index Permission.Manage in let manage_permission () = - CCList.mem (of_tuple (Permission.Manage, model, target_uuid)) perms + let manage = of_tuple (Permission.Manage, model, target_uuid) in + match target_uuid with + | None -> PotSet.mem manage model_wide + | Some _ -> PotSet.mem manage manage_on_uuid in match target_uuid with | None when is_manage_model () -> permission_on_target :: init @@ -330,7 +354,6 @@ struct (validation_set : ValidationSet.t) actor = - let open CCFun in let rec find_checker : validation_set -> bool = let open ValidationSet in function @@ -351,7 +374,7 @@ struct | true -> true | false -> CCList.fold_left - (flip (fun rule -> function + (CCFun.flip (fun rule -> function | true -> true | false -> find_checker rule)) false @@ -361,7 +384,7 @@ struct | false -> false | true -> CCList.fold_left - (flip (fun rule -> function + (CCFun.flip (fun rule -> function | true -> find_checker rule | false -> false)) true @@ -412,8 +435,7 @@ struct actor : (unit, 'etyp) Lwt_result.t = - let open CCFun in - let ( |>> ) = flip Lwt.map in + let ( |>> ) = CCFun.flip Lwt.map in let rec find_checker = let open ValidationSet in function @@ -424,7 +446,7 @@ struct | true -> Lwt.return_true | false -> Lwt_list.fold_left_s - (flip (fun rule -> function + (CCFun.flip (fun rule -> function | true -> Lwt.return_true | false -> find_checker rule)) false @@ -434,7 +456,7 @@ struct | false -> Lwt.return_false | true -> Lwt_list.fold_left_s - (flip (fun rule -> function + (CCFun.flip (fun rule -> function | true -> find_checker rule | false -> Lwt.return_false)) true diff --git a/lib/utils.ml b/lib/utils.ml index ddda0b4..42f961e 100644 --- a/lib/utils.ml +++ b/lib/utils.ml @@ -1,4 +1,4 @@ -open CCFun +open CCFun.Infix let hide_typ f (_ : 'a) = Format.pp_print_string f "" diff --git a/test/main.ml b/test/main.ml index 333e447..fb677c0 100644 --- a/test/main.ml +++ b/test/main.ml @@ -206,7 +206,7 @@ module Tests (Backend : Guard.PersistenceSig) = struct ;; let save_existing_rule ?ctx (_ : 'a) () = - let existing_rule = List.hd global_role_permission in + let existing_rule = CCList.hd global_role_permission in (let* () = Backend.RolePermission.insert ?ctx existing_rule in Backend.RolePermission.insert ?ctx existing_rule) >|= Alcotest.(check (result unit string)) "Save existing permission" (Ok ()) @@ -1074,6 +1074,142 @@ module Tests (Backend : Guard.PersistenceSig) = struct (CCResult.is_error result); Lwt.return_unit ;; + + (* Cache behaviour: cached validations must be invalidated when the actor's + roles change, when role permission rules change, and when a target is + promoted to another model. Each test validates before mutating so a + cached (stale) entry exists when the mutation happens. *) + + let test_cache_role_invalidation ?ctx (_ : 'a) () = + let actor_uuid = Uuid.Actor.create () in + let actor = Actor.create `User actor_uuid in + let set = ValidationSet.one_of_tuple (Read, `Post, None) in + let validate () = Backend.validate ?ctx id set actor in + let check msg expected result = + Alcotest.(check bool) msg expected (CCResult.is_ok result) + in + (let* () = Backend.Actor.insert ?ctx actor in + let%lwt denied = validate () in + check "no role: denied" false denied; + let%lwt denied_cached = validate () in + check "no role: still denied from cache" false denied_cached; + let role = ActorRole.create actor_uuid `Reader in + let%lwt () = Backend.ActorRole.upsert ?ctx role in + let%lwt granted = validate () in + check "role granted: cached denial invalidated" true granted; + let%lwt () = Backend.ActorRole.delete ?ctx role in + let%lwt denied_again = validate () in + check "role revoked: cached grant invalidated" false denied_again; + Lwt.return_ok ()) + >|= Alcotest.(check (result unit string)) + "cache follows role changes" + (Ok ()) + ;; + + let test_cache_rule_invalidation ?ctx (_ : 'a) () = + let actor_uuid = Uuid.Actor.create () in + let actor = Actor.create `User actor_uuid in + let rule = RolePermission.create `Author Read `Note in + let set = ValidationSet.one_of_tuple (Read, `Note, None) in + let validate () = Backend.validate ?ctx id set actor in + let check msg expected result = + Alcotest.(check bool) msg expected (CCResult.is_ok result) + in + (let* () = Backend.Actor.insert ?ctx actor in + let%lwt () = + Backend.ActorRole.upsert ?ctx (ActorRole.create actor_uuid `Author) + in + let%lwt denied = validate () in + check "no rule: denied" false denied; + let* () = Backend.RolePermission.insert ?ctx rule in + let%lwt granted = validate () in + check "rule inserted: cached denial invalidated" true granted; + let* () = Backend.RolePermission.delete ?ctx rule in + let%lwt denied_again = validate () in + check "rule deleted: cached grant invalidated" false denied_again; + Lwt.return_ok ()) + >|= Alcotest.(check (result unit string)) + "cache follows rule changes" + (Ok ()) + ;; + + let test_promote_refreshes_model ?ctx (_ : 'a) () = + let actor_uuid = Uuid.Actor.create () in + let actor = Actor.create `User actor_uuid in + let target_uuid = Uuid.Target.create () in + (* validate by uuid only, so the backend resolves (and caches) the + target's model itself *) + let validate () = Backend.Repo.validate ?ctx ~target_uuid Read actor in + (let* () = Backend.Actor.insert ?ctx actor in + let%lwt () = + Backend.ActorRole.upsert ?ctx (ActorRole.create actor_uuid `Reader) + in + let* () = Backend.Target.insert ?ctx (Target.create `Note target_uuid) in + let%lwt denied = validate () in + Alcotest.(check bool) "note target: reader denied" false denied; + let%lwt () = Backend.Target.promote ?ctx target_uuid `Post in + let%lwt granted = validate () in + Alcotest.(check bool) + "promoted to post: model resolution is not stale" + true + granted; + Lwt.return_ok ()) + >|= Alcotest.(check (result unit string)) + "promote refreshes target model" + (Ok ()) + ;; + + let test_mixed_role_scopes ?ctx (_ : 'a) () = + let actor_uuid = Uuid.Actor.create () in + let actor = Actor.create `User actor_uuid in + let target_uuid = Uuid.Target.create () in + let model_role = ActorRole.create actor_uuid `Editor in + let targeted_role = ActorRole.create ~target_uuid actor_uuid `Editor in + (let* () = Backend.Actor.insert ?ctx actor in + let* () = + Backend.Target.insert ?ctx (Target.create `Article target_uuid) + in + let%lwt () = Backend.ActorRole.upsert ?ctx model_role in + let%lwt () = Backend.ActorRole.upsert ?ctx targeted_role in + let%lwt roles = Backend.ActorRole.find_by_actor ?ctx actor_uuid in + let mem role = CCList.mem ~eq:ActorRole.equal role roles in + Alcotest.(check bool) "model-scoped role returned" true (mem model_role); + Alcotest.(check bool) + "target-scoped role returned" + true + (mem targeted_role); + Alcotest.(check int) + "exactly the two granted roles" + 2 + (CCList.length roles); + Lwt.return_ok ()) + >|= Alcotest.(check (result unit string)) + "model and targeted roles of the same name coexist" + (Ok ()) + ;; + + let test_permission_duplicate_sources ?ctx (_ : 'a) () = + (* the same (permission, model) grant coming from both a role rule and a + direct actor permission must appear only once *) + let actor_uuid = Uuid.Actor.create () in + let actor = Actor.create `User actor_uuid in + let direct = ActorPermission.create_for_model actor_uuid Update `Article in + (let* () = Backend.Actor.insert ?ctx actor in + let%lwt () = + Backend.ActorRole.upsert ?ctx (ActorRole.create actor_uuid `Author) + in + let* () = Backend.ActorPermission.insert ?ctx direct in + let%lwt perms = Backend.ActorRole.permissions_of_actor ?ctx actor_uuid in + let expected = PermissionOnTarget.of_tuple (Update, `Article, None) in + let occurrences = + CCList.filter (PermissionOnTarget.equal expected) perms |> CCList.length + in + Alcotest.(check int) "duplicate grant appears once" 1 occurrences; + Backend.ActorPermission.delete ?ctx direct) + >|= Alcotest.(check (result unit string)) + "grant from role rule and actor permission is deduplicated" + (Ok ()) + ;; end let role_model_tests = @@ -1251,6 +1387,24 @@ let () = `Quick (test_actor_no_roles ?ctx) ] ) + ; ( Format.asprintf "(%s) Cache invalidation" name + , [ test_case "role changes" `Quick (test_cache_role_invalidation ?ctx) + ; test_case "rule changes" `Quick (test_cache_rule_invalidation ?ctx) + ; test_case + "promote refreshes target model" + `Quick + (test_promote_refreshes_model ?ctx) + ] ) + ; ( Format.asprintf "(%s) Role scopes and duplicate grants" name + , [ test_case + "model and targeted roles" + `Quick + (test_mixed_role_scopes ?ctx) + ; test_case + "duplicate grant appears once" + `Quick + (test_permission_duplicate_sources ?ctx) + ] ) ] in let open Guardian_backend.Pools in