From e95092830c9a573423bc0d525c23284d580153bf Mon Sep 17 00:00:00 2001 From: Leandro Ostera Date: Fri, 24 Nov 2023 14:48:54 +0100 Subject: [PATCH] feat: Add Experiment Filters for Invitations (#258) * feat: sketch additional invitation and assignment filters * test: add first test for experiment filter * chore: format * preliminary create all search tables before querying * clean test, make error message more helpful * get invitation filter working * add exclusion tests * Address pr comments --- esy.json | 8 +- esy.lock/index.json | 75 +++--- .../opam | 8 +- .../{tls-lwt.0.17.1 => tls-lwt.0.17.3}/opam | 8 +- esy.lock/opam/{tls.0.17.1 => tls.0.17.3}/opam | 8 +- pool.opam | 2 +- pool/app/filter/entity.ml | 8 +- pool/app/filter/filter.mli | 1 + pool/app/filter/repo/repo.ml | 83 +++++- pool/app/filter/repo/repo_utils.ml | 33 ++- pool/app/pool_common/locales/locales_en.ml | 4 +- pool/run/dune | 1 + pool/test/dune | 2 +- pool/test/filter_invitation_tests.ml | 253 ++++++++++++++++++ pool/test/integration.ml | 10 + pool/test/test_utils.ml | 6 +- 16 files changed, 430 insertions(+), 80 deletions(-) rename esy.lock/opam/{ocaml-lsp-server.1.16.2 => ocaml-lsp-server.1.16.1}/opam (80%) rename esy.lock/opam/{tls-lwt.0.17.1 => tls-lwt.0.17.3}/opam (78%) rename esy.lock/opam/{tls.0.17.1 => tls.0.17.3}/opam (87%) create mode 100644 pool/test/filter_invitation_tests.ml diff --git a/esy.json b/esy.json index 949af8d34..a85a3efd0 100644 --- a/esy.json +++ b/esy.json @@ -10,15 +10,12 @@ "@opam/containers": "3.12", "@opam/containers-data": "3.12", "@opam/cstruct": "*", - "@opam/dune": "*", "@opam/guardian": "*", "@opam/logs": "0.7.0", "@opam/lwt": "5.7.0", "@opam/lwt_ppx": "2.1.0", "@opam/lwt_ssl": "1.2.0", "@opam/mariadb": "*", - "@opam/ocaml-lsp-server": "*", - "@opam/ocamlformat": "0.26.1", "@opam/mirage-crypto": "*", "@opam/mirage-crypto-rng": "*", "@opam/mirage-crypto-rng-lwt": "*", @@ -40,6 +37,11 @@ "esy-openssl": "*", "ocaml": "4.14.0" }, + "devDependencies": { + "@opam/dune": "*", + "@opam/ocamlformat": "*", + "@opam/ocaml-lsp-server": "*" + }, "resolutions": { "@opam/canary": "uzh/canary#02cf40e029268560e160ca032850426e387aa598", "@opam/comformist": "oxidizing/conformist#aa7b95d1f39215cdaab8cf96d765d63e41d5f8a6", diff --git a/esy.lock/index.json b/esy.lock/index.json index 09f2c6c09..fbf83d657 100644 --- a/esy.lock/index.json +++ b/esy.lock/index.json @@ -1,5 +1,5 @@ { - "checksum": "c38a723954c6a0e2ea16cbe887202f3a", + "checksum": "1f0a1b8c4048915f4cd00ae39c647598", "root": "pool@link-dev:./esy.json", "node": { "yarn-pkg-config@github:esy-ocaml/yarn-pkg-config#db3a0b63883606dd57c54a7158d560d6cba8cd79@d41d8cd9": { @@ -39,8 +39,6 @@ "@opam/ppx_sexp_conv@opam:v0.16.0@bae11ff6", "@opam/ppx_inline_test@opam:v0.16.1@955ee3a7", "@opam/ppx_deriving@opam:5.2.1@2315fdd0", - "@opam/ocamlformat@opam:0.26.1@3a835116", - "@opam/ocaml-lsp-server@opam:1.16.2@6e0031b9", "@opam/mirage-crypto-rng-lwt@opam:0.11.2@ec98ed6d", "@opam/mirage-crypto-rng@opam:0.11.2@b3a0290a", "@opam/mirage-crypto-pk@opam:0.11.2@d39f88e2", @@ -50,7 +48,6 @@ "@opam/lwt_ppx@opam:2.1.0@f0dd3e73", "@opam/lwt@opam:5.7.0@4a33823d", "@opam/logs@opam:0.7.0@46a3dffc", "@opam/guardian@github:uzh/guardian#9f68a2afa4a3517cbb2f85d0748fb7e00ab8e226@d41d8cd9", - "@opam/dune@opam:3.11.1@ba2e0e6a", "@opam/cstruct@opam:6.2.0@7f5eb076", "@opam/containers-data@opam:3.12@7c3c31e1", "@opam/containers@opam:3.12@c6cdb677", @@ -62,7 +59,11 @@ "@opam/canary@github:uzh/canary#02cf40e029268560e160ca032850426e387aa598@d41d8cd9", "@opam/alcotest-lwt@opam:1.7.0@b5d3b247" ], - "devDependencies": [] + "devDependencies": [ + "@opam/ocamlformat@opam:0.26.1@3a835116", + "@opam/ocaml-lsp-server@opam:1.16.1@b7306101", + "@opam/dune@opam:3.11.1@ba2e0e6a" + ] }, "ocaml@4.14.0@d41d8cd9": { "id": "ocaml@4.14.0@d41d8cd9", @@ -805,26 +806,26 @@ "ocaml@4.14.0@d41d8cd9", "@opam/ocamlbuild@opam:0.14.2+win@39b9f56d" ] }, - "@opam/tls-lwt@opam:0.17.1@d15dd45f": { - "id": "@opam/tls-lwt@opam:0.17.1@d15dd45f", + "@opam/tls-lwt@opam:0.17.3@a4e56688": { + "id": "@opam/tls-lwt@opam:0.17.3@a4e56688", "name": "@opam/tls-lwt", - "version": "opam:0.17.1", + "version": "opam:0.17.3", "source": { "type": "install", "source": [ - "archive:https://opam.ocaml.org/cache/sha256/80/8010d2b6de148da2286928181d233bd720fa60fa157b3d4250bca0dd008c5d3f#sha256:8010d2b6de148da2286928181d233bd720fa60fa157b3d4250bca0dd008c5d3f", - "archive:https://github.com/mirleft/ocaml-tls/releases/download/v0.17.1/tls-0.17.1.tbz#sha256:8010d2b6de148da2286928181d233bd720fa60fa157b3d4250bca0dd008c5d3f" + "archive:https://opam.ocaml.org/cache/sha256/47/47e5decdd30ed1c367736458a63ae077474147b3dd675c14590b81a92d5031d4#sha256:47e5decdd30ed1c367736458a63ae077474147b3dd675c14590b81a92d5031d4", + "archive:https://github.com/mirleft/ocaml-tls/releases/download/v0.17.3/tls-0.17.3.tbz#sha256:47e5decdd30ed1c367736458a63ae077474147b3dd675c14590b81a92d5031d4" ], "opam": { "name": "tls-lwt", - "version": "0.17.1", - "path": "esy.lock/opam/tls-lwt.0.17.1" + "version": "0.17.3", + "path": "esy.lock/opam/tls-lwt.0.17.3" } }, "overrides": [], "dependencies": [ "ocaml@4.14.0@d41d8cd9", "@opam/x509@opam:0.16.5@1e128d7a", - "@opam/tls@opam:0.17.1@453fce9a", + "@opam/tls@opam:0.17.3@2bb9fa18", "@opam/mirage-crypto-rng-lwt@opam:0.11.2@ec98ed6d", "@opam/lwt@opam:5.7.0@4a33823d", "@opam/dune@opam:3.11.1@ba2e0e6a", "@opam/cmdliner@opam:1.2.0@b0c6143c", @@ -832,26 +833,26 @@ ], "devDependencies": [ "ocaml@4.14.0@d41d8cd9", "@opam/x509@opam:0.16.5@1e128d7a", - "@opam/tls@opam:0.17.1@453fce9a", + "@opam/tls@opam:0.17.3@2bb9fa18", "@opam/mirage-crypto-rng-lwt@opam:0.11.2@ec98ed6d", "@opam/lwt@opam:5.7.0@4a33823d", "@opam/dune@opam:3.11.1@ba2e0e6a", "@opam/cmdliner@opam:1.2.0@b0c6143c" ] }, - "@opam/tls@opam:0.17.1@453fce9a": { - "id": "@opam/tls@opam:0.17.1@453fce9a", + "@opam/tls@opam:0.17.3@2bb9fa18": { + "id": "@opam/tls@opam:0.17.3@2bb9fa18", "name": "@opam/tls", - "version": "opam:0.17.1", + "version": "opam:0.17.3", "source": { "type": "install", "source": [ - "archive:https://opam.ocaml.org/cache/sha256/80/8010d2b6de148da2286928181d233bd720fa60fa157b3d4250bca0dd008c5d3f#sha256:8010d2b6de148da2286928181d233bd720fa60fa157b3d4250bca0dd008c5d3f", - "archive:https://github.com/mirleft/ocaml-tls/releases/download/v0.17.1/tls-0.17.1.tbz#sha256:8010d2b6de148da2286928181d233bd720fa60fa157b3d4250bca0dd008c5d3f" + "archive:https://opam.ocaml.org/cache/sha256/47/47e5decdd30ed1c367736458a63ae077474147b3dd675c14590b81a92d5031d4#sha256:47e5decdd30ed1c367736458a63ae077474147b3dd675c14590b81a92d5031d4", + "archive:https://github.com/mirleft/ocaml-tls/releases/download/v0.17.3/tls-0.17.3.tbz#sha256:47e5decdd30ed1c367736458a63ae077474147b3dd675c14590b81a92d5031d4" ], "opam": { "name": "tls", - "version": "0.17.1", - "path": "esy.lock/opam/tls.0.17.1" + "version": "0.17.3", + "path": "esy.lock/opam/tls.0.17.3" } }, "overrides": [], @@ -1244,7 +1245,7 @@ "dependencies": [ "ocaml@4.14.0@d41d8cd9", "@opam/yojson@opam:2.1.1@ad5e299c", "@opam/uuidm@opam:0.9.8@f287a426", "@opam/tsort@opam:2.1.0@d2fd3b79", - "@opam/tls@opam:0.17.1@453fce9a", "@opam/ssl@opam:0.7.0@d7b5a7dd", + "@opam/tls@opam:0.17.3@2bb9fa18", "@opam/ssl@opam:0.7.0@d7b5a7dd", "@opam/sexplib@opam:v0.16.0@e65b80ca", "@opam/safepass@opam:3.1@da7ff931", "@opam/ppx_sexp_conv@opam:v0.16.0@bae11ff6", @@ -1270,7 +1271,7 @@ "devDependencies": [ "ocaml@4.14.0@d41d8cd9", "@opam/yojson@opam:2.1.1@ad5e299c", "@opam/uuidm@opam:0.9.8@f287a426", "@opam/tsort@opam:2.1.0@d2fd3b79", - "@opam/tls@opam:0.17.1@453fce9a", "@opam/ssl@opam:0.7.0@d7b5a7dd", + "@opam/tls@opam:0.17.3@2bb9fa18", "@opam/ssl@opam:0.7.0@d7b5a7dd", "@opam/sexplib@opam:v0.16.0@e65b80ca", "@opam/safepass@opam:3.1@da7ff931", "@opam/ppx_sexp_conv@opam:v0.16.0@bae11ff6", @@ -1383,7 +1384,7 @@ }, "overrides": [], "dependencies": [ - "ocaml@4.14.0@d41d8cd9", "@opam/tls@opam:0.17.1@453fce9a", + "ocaml@4.14.0@d41d8cd9", "@opam/tls@opam:0.17.3@2bb9fa18", "@opam/rresult@opam:0.7.0@0042fa02", "@opam/logs@opam:0.7.0@46a3dffc", "@opam/ke@opam:0.6@9ad9641b", "@opam/dune@opam:3.11.1@ba2e0e6a", @@ -1394,7 +1395,7 @@ "@esy-ocaml/substs@0.0.1@d41d8cd9" ], "devDependencies": [ - "ocaml@4.14.0@d41d8cd9", "@opam/tls@opam:0.17.1@453fce9a", + "ocaml@4.14.0@d41d8cd9", "@opam/tls@opam:0.17.3@2bb9fa18", "@opam/rresult@opam:0.7.0@0042fa02", "@opam/logs@opam:0.7.0@46a3dffc", "@opam/ke@opam:0.6@9ad9641b", "@opam/dune@opam:3.11.1@ba2e0e6a", @@ -2777,20 +2778,20 @@ "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.11.1@ba2e0e6a" ] }, - "@opam/ocaml-lsp-server@opam:1.16.2@6e0031b9": { - "id": "@opam/ocaml-lsp-server@opam:1.16.2@6e0031b9", + "@opam/ocaml-lsp-server@opam:1.16.1@b7306101": { + "id": "@opam/ocaml-lsp-server@opam:1.16.1@b7306101", "name": "@opam/ocaml-lsp-server", - "version": "opam:1.16.2", + "version": "opam:1.16.1", "source": { "type": "install", "source": [ - "archive:https://opam.ocaml.org/cache/sha256/14/1487d5a4e2f2d4f023341058551bdb8ba86c23367b7c5b4fdda3aa7dc02aaec4#sha256:1487d5a4e2f2d4f023341058551bdb8ba86c23367b7c5b4fdda3aa7dc02aaec4", - "archive:https://github.com/ocaml/ocaml-lsp/releases/download/1.16.2/lsp-1.16.2.tbz#sha256:1487d5a4e2f2d4f023341058551bdb8ba86c23367b7c5b4fdda3aa7dc02aaec4" + "archive:https://opam.ocaml.org/cache/sha256/84/84fb305afbb9935e03bec286dc938f9e4ae768c1766e8d10238e0d812a8c04e6#sha256:84fb305afbb9935e03bec286dc938f9e4ae768c1766e8d10238e0d812a8c04e6", + "archive:https://github.com/ocaml/ocaml-lsp/releases/download/1.16.1/lsp-1.16.1.tbz#sha256:84fb305afbb9935e03bec286dc938f9e4ae768c1766e8d10238e0d812a8c04e6" ], "opam": { "name": "ocaml-lsp-server", - "version": "1.16.2", - "path": "esy.lock/opam/ocaml-lsp-server.1.16.2" + "version": "1.16.1", + "path": "esy.lock/opam/ocaml-lsp-server.1.16.1" } }, "overrides": [], @@ -3561,8 +3562,8 @@ "overrides": [], "dependencies": [ "ocaml@4.14.0@d41d8cd9", "@opam/x509@opam:0.16.5@1e128d7a", - "@opam/tls-lwt@opam:0.17.1@d15dd45f", - "@opam/tls@opam:0.17.1@453fce9a", + "@opam/tls-lwt@opam:0.17.3@a4e56688", + "@opam/tls@opam:0.17.3@2bb9fa18", "@opam/sendmail@opam:0.8.0@5dec20fa", "@opam/ptime@opam:1.1.0@d6f12219", "@opam/mrmime@opam:0.6.0@8f03e41b", "@opam/lwt@opam:5.7.0@4a33823d", @@ -3574,8 +3575,8 @@ ], "devDependencies": [ "ocaml@4.14.0@d41d8cd9", "@opam/x509@opam:0.16.5@1e128d7a", - "@opam/tls-lwt@opam:0.17.1@d15dd45f", - "@opam/tls@opam:0.17.1@453fce9a", + "@opam/tls-lwt@opam:0.17.3@a4e56688", + "@opam/tls@opam:0.17.3@2bb9fa18", "@opam/sendmail@opam:0.8.0@5dec20fa", "@opam/ptime@opam:1.1.0@d6f12219", "@opam/mrmime@opam:0.6.0@8f03e41b", "@opam/lwt@opam:5.7.0@4a33823d", @@ -4979,7 +4980,7 @@ "overrides": [], "dependencies": [ "ocaml@4.14.0@d41d8cd9", "@opam/uri@opam:4.4.0@f70a0b72", - "@opam/tls-lwt@opam:0.17.1@d15dd45f", + "@opam/tls-lwt@opam:0.17.3@a4e56688", "@opam/ppx_sexp_conv@opam:v0.16.0@bae11ff6", "@opam/lwt_ssl@opam:1.2.0@f28229d5", "@opam/lwt@opam:5.7.0@4a33823d", "@opam/logs@opam:0.7.0@46a3dffc", diff --git a/esy.lock/opam/ocaml-lsp-server.1.16.2/opam b/esy.lock/opam/ocaml-lsp-server.1.16.1/opam similarity index 80% rename from esy.lock/opam/ocaml-lsp-server.1.16.2/opam rename to esy.lock/opam/ocaml-lsp-server.1.16.1/opam index 2f8512e11..b28d4ff73 100644 --- a/esy.lock/opam/ocaml-lsp-server.1.16.2/opam +++ b/esy.lock/opam/ocaml-lsp-server.1.16.1/opam @@ -57,10 +57,10 @@ build: [ ] url { src: - "https://github.com/ocaml/ocaml-lsp/releases/download/1.16.2/lsp-1.16.2.tbz" + "https://github.com/ocaml/ocaml-lsp/releases/download/1.16.1/lsp-1.16.1.tbz" checksum: [ - "sha256=1487d5a4e2f2d4f023341058551bdb8ba86c23367b7c5b4fdda3aa7dc02aaec4" - "sha512=4a392f6d3deafc6dd37f9603250e736c8d8195ea42c782252386616e8c1562d744e02beee54ec45254cba23efd343ebb33789babb093b0e70122ba86d7e67717" + "sha256=84fb305afbb9935e03bec286dc938f9e4ae768c1766e8d10238e0d812a8c04e6" + "sha512=eae42ed16c5e38f7512dfc6338ecae6d9a13054e9821cffbc9afd6fc79a0736ef81b55222e4a2d49ba51ec8a08009c06a4bbdfe424460c0b3a54e28b23fda36e" ] } -x-commit-hash: "22cefd841bb0b6b9a6fd4fe5befe5eb68d213ce3" +x-commit-hash: "1f78031bcaecda696419e893253333566fcd87f3" diff --git a/esy.lock/opam/tls-lwt.0.17.1/opam b/esy.lock/opam/tls-lwt.0.17.3/opam similarity index 78% rename from esy.lock/opam/tls-lwt.0.17.1/opam rename to esy.lock/opam/tls-lwt.0.17.3/opam index dee4bb35b..d9321b812 100644 --- a/esy.lock/opam/tls-lwt.0.17.1/opam +++ b/esy.lock/opam/tls-lwt.0.17.3/opam @@ -32,10 +32,10 @@ authors: [ ] url { src: - "https://github.com/mirleft/ocaml-tls/releases/download/v0.17.1/tls-0.17.1.tbz" + "https://github.com/mirleft/ocaml-tls/releases/download/v0.17.3/tls-0.17.3.tbz" checksum: [ - "sha256=8010d2b6de148da2286928181d233bd720fa60fa157b3d4250bca0dd008c5d3f" - "sha512=1cef22fc37b3138d1676f5a2d3000835167fb75dad07cec5e851e19c3af3250a30392a49e279e5b1f3119de29383723fb76f2bd830820b45861053047c85da1a" + "sha256=47e5decdd30ed1c367736458a63ae077474147b3dd675c14590b81a92d5031d4" + "sha512=da0765852ebaa0badab2600e77b9f602e7b68784d35845bcf44ee87639b14247abdeb08190df5882dd99aa59d534dbc5119c32994446604eb38e4c72d30c0f06" ] } -x-commit-hash: "a421e3a696e88279df25f9eea928a62dd3730082" +x-commit-hash: "766eb22f5f7562899c653c5ec5ce5b95070fc8ec" diff --git a/esy.lock/opam/tls.0.17.1/opam b/esy.lock/opam/tls.0.17.3/opam similarity index 87% rename from esy.lock/opam/tls.0.17.1/opam rename to esy.lock/opam/tls.0.17.3/opam index 462f4c9e9..c5e666162 100644 --- a/esy.lock/opam/tls.0.17.1/opam +++ b/esy.lock/opam/tls.0.17.3/opam @@ -54,10 +54,10 @@ authors: [ ] url { src: - "https://github.com/mirleft/ocaml-tls/releases/download/v0.17.1/tls-0.17.1.tbz" + "https://github.com/mirleft/ocaml-tls/releases/download/v0.17.3/tls-0.17.3.tbz" checksum: [ - "sha256=8010d2b6de148da2286928181d233bd720fa60fa157b3d4250bca0dd008c5d3f" - "sha512=1cef22fc37b3138d1676f5a2d3000835167fb75dad07cec5e851e19c3af3250a30392a49e279e5b1f3119de29383723fb76f2bd830820b45861053047c85da1a" + "sha256=47e5decdd30ed1c367736458a63ae077474147b3dd675c14590b81a92d5031d4" + "sha512=da0765852ebaa0badab2600e77b9f602e7b68784d35845bcf44ee87639b14247abdeb08190df5882dd99aa59d534dbc5119c32994446604eb38e4c72d30c0f06" ] } -x-commit-hash: "a421e3a696e88279df25f9eea928a62dd3730082" +x-commit-hash: "766eb22f5f7562899c653c5ec5ce5b95070fc8ec" diff --git a/pool.opam b/pool.opam index af5505ed4..b16957583 100644 --- a/pool.opam +++ b/pool.opam @@ -29,7 +29,7 @@ depends: [ "containers-data" {>= "3.6"} "mariadb" {>= "1.1.6" & < "2.0.0"} "caqti-driver-mariadb" {>= "2.0.1"} - "caqti-lwt" {>= "2.0.1" } + "caqti-lwt" {>= "2.0.1"} "caqti" {>= "2.0.1"} "ocamlformat" {>= "0.18.0"} "ppx_deriving" {>= "5.2.1"} diff --git a/pool/app/filter/entity.ml b/pool/app/filter/entity.ml index 7121b482a..f50378b20 100644 --- a/pool/app/filter/entity.ml +++ b/pool/app/filter/entity.ml @@ -126,6 +126,7 @@ module Key = struct [@name "num_participations"] | NumShowUps [@printer print "num_show_ups"] [@name "num_show_ups"] | Participation [@printer print "participation"] [@name "participation"] + | Invitation [@printer print "invitation"] [@name "invitation"] | Tag [@printer print "tag"] [@name "tag"] [@@deriving show { with_path = false }, eq, yojson, variants, enum] @@ -205,7 +206,7 @@ module Key = struct | NumNoShows -> Ok "pool_contacts.num_no_shows" | NumParticipations -> Ok "pool_contacts.num_participations" | NumShowUps -> Ok "pool_contacts.num_show_ups" - | Participation | Tag -> + | Invitation | Participation | Tag -> Error Pool_common.Message.(QueryNotCompatible (Field.Key, Field.Value)) ;; @@ -219,7 +220,7 @@ module Key = struct | NumNoShows | NumParticipations | NumShowUps -> Nr - | Participation -> QueryExperiments + | Invitation | Participation -> QueryExperiments | Tag -> QueryTags ;; @@ -531,8 +532,7 @@ module Operator = struct | NumNoShows | NumParticipations | NumShowUps -> all_equality_operators @ all_size_operators - | Participation -> all_list_operators - | Tag -> all_list_operators + | Participation | Tag | Invitation -> all_list_operators ;; let input_type_to_operator (key : Key.input_type) = diff --git a/pool/app/filter/filter.mli b/pool/app/filter/filter.mli index f673bc7dc..a20924ed4 100644 --- a/pool/app/filter/filter.mli +++ b/pool/app/filter/filter.mli @@ -41,6 +41,7 @@ module Key : sig | NumParticipations | NumShowUps | Participation + | Invitation | Tag type t = diff --git a/pool/app/filter/repo/repo.ml b/pool/app/filter/repo/repo.ml index f716e77c0..6b6ce24e5 100644 --- a/pool/app/filter/repo/repo.ml +++ b/pool/app/filter/repo/repo.ml @@ -189,13 +189,20 @@ module Sql = struct ;; let drop_temp_table connection = - let open Caqti_request.Infix in - let (module Connection : Caqti_lwt.CONNECTION) = connection in - let request = - {sql| DROP TEMPORARY TABLE IF EXISTS tmp_participations; |sql} - |> Caqti_type.(unit ->. unit) + let run_query q = + let open Caqti_request.Infix in + let (module Connection : Caqti_lwt.CONNECTION) = connection in + let request = q |> Caqti_type.(unit ->. unit) in + Connection.exec request () in - Connection.exec request () + let queries = + [ {sql| DROP TEMPORARY TABLE IF EXISTS tmp_participations; |sql} + ; {sql| DROP TEMPORARY TABLE IF EXISTS tmp_invitations; |sql} + ] + in + Lwt_list.map_s run_query queries + |> Lwt.map CCResult.flatten_l + |> Lwt_result.map (fun (_ : unit list) -> ()) ;; let find_participation_experiments_of_query query = @@ -226,6 +233,44 @@ module Sql = struct | Bool _ | Date _ | Language _ | Nr _ | Option _ -> None) ;; + let create_temporary_invitation_table query = + let open Dynparam in + let open Caqti_request.Infix in + let create_request ids = + Format.asprintf + {sql| + CREATE TEMPORARY TABLE tmp_invitations AS ( + SELECT + pool_invitations.contact_uuid AS contact_uuid, + pool_invitations.experiment_uuid AS experiment_uuid + FROM pool_invitations + WHERE experiment_uuid IN ( %s )) + |sql} + (CCList.mapi + (fun i _ -> Format.asprintf "UNHEX(REPLACE($%n, '-', ''))" (i + 1)) + ids + |> CCString.concat ",") + in + let open CCOption in + let fnc connection = + query + >|= Repo_utils.find_experiments_by_key Key.Invitation + |> function + | None | Some [] -> Lwt_result.return () + | Some ids -> + let (Pack (pt, pv)) = + CCList.fold_left + (fun dyn id -> dyn |> add Caqti_type.string id) + empty + ids + in + let (module Connection : Caqti_lwt.CONNECTION) = connection in + let request = create_request ids |> pt ->. Caqti_type.unit in + Connection.exec request pv + in + fnc + ;; + let create_temporary_participation_table query = let open Dynparam in let open Caqti_request.Infix in @@ -251,7 +296,7 @@ module Sql = struct let open CCOption in let fnc connection = query - >|= Repo_utils.find_participation_experiments_of_query + >|= Repo_utils.find_experiments_by_key Key.Participation |> function | None | Some [] -> Lwt_result.return () | Some ids -> @@ -295,7 +340,11 @@ module Sql = struct let find_filtered_contacts pool ?order_by ?limit use_case filter = let filter = filter |> CCOption.map (fun f -> f.Entity.query) in let open Utils.Lwt_result.Infix in - let create_temp_table = create_temporary_participation_table filter in + let create_temp_tables = + [ create_temporary_participation_table filter + ; create_temporary_invitation_table filter + ] + in let%lwt template_list = match filter with | None -> Lwt.return [] @@ -326,7 +375,7 @@ module Sql = struct in Utils.Database.find_as_transaction (pool |> Pool_database.Label.value) - ~setup:[ drop_temp_table; create_temp_table ] + ~setup:(drop_temp_table :: create_temp_tables) ~cleanup:[ drop_temp_table ] query ||> CCResult.return @@ -350,7 +399,11 @@ module Sql = struct where_fragment in let%lwt template_list = find_templates_of_query pool query in - let create_temp_table = create_temporary_participation_table (Some query) in + let create_temp_tables = + [ create_temporary_participation_table (Some query) + ; create_temporary_invitation_table (Some query) + ] + in filtered_params MatchesFilter template_list (Some query) |> CCResult.map_err (Pool_common.Utils.with_log_error ~src ~level:Logs.Warning ~tags) @@ -369,7 +422,7 @@ module Sql = struct in Utils.Database.find_as_transaction (pool |> Pool_database.Label.value) - ~setup:[ drop_temp_table; create_temp_table ] + ~setup:(drop_temp_table :: create_temp_tables) ~cleanup:[ drop_temp_table ] matches_filter_request ||> CCOption.map_or ~default (CCInt.equal 1) @@ -420,7 +473,11 @@ module Sql = struct let open Utils.Lwt_result.Infix in let open Caqti_request.Infix in let open Dynparam in - let create_temp_table = create_temporary_participation_table query in + let create_temp_tables = + [ create_temporary_participation_table query + ; create_temporary_invitation_table query + ] + in let%lwt template_list = match query with | None -> Lwt.return [] @@ -439,7 +496,7 @@ module Sql = struct in Utils.Database.find_as_transaction (pool |> Pool_database.Label.value) - ~setup:[ drop_temp_table; create_temp_table ] + ~setup:(drop_temp_table :: create_temp_tables) ~cleanup:[ drop_temp_table ] query ||> CCOption.value ~default:0 diff --git a/pool/app/filter/repo/repo_utils.ml b/pool/app/filter/repo/repo_utils.ml index 97f03e857..c0d557dd8 100644 --- a/pool/app/filter/repo/repo_utils.ml +++ b/pool/app/filter/repo/repo_utils.ml @@ -176,6 +176,34 @@ let add_list_condition subquery dyn ids = Error Message.(Invalid Field.Operator) ;; +(* The subquery returns any contacts that has been invited to an experiment. *) +let invitation_subquery dyn operator ids = + let open CCResult in + let* dyn, query_params = add_uuid_param dyn ids in + let subquery ~count = + let col = "DISTINCT tmp_invitations.experiment_uuid" in + let select = if count then Format.asprintf "COUNT(%s)" col else col in + let base = + Format.asprintf + {sql| + SELECT + %s + FROM + tmp_invitations + WHERE + tmp_invitations.contact_uuid = pool_contacts.user_uuid + AND tmp_invitations.experiment_uuid IN (%s) + |sql} + select + query_params + in + if count + then Format.asprintf "%s GROUP BY tmp_invitations.contact_uuid" base + else base + in + add_list_condition subquery dyn ids operator +;; + (* The subquery does not return any contacts that have shown up at a session of the current experiment. It does not make a difference, if they participated. *) @@ -254,6 +282,7 @@ let predicate_to_sql | Hardcoded hardcoded -> (match hardcoded with | Participation -> participation_subquery dyn operator values + | Invitation -> invitation_subquery dyn operator values | Tag -> tag_subquery dyn operator values | ContactLanguage | Firstname @@ -387,7 +416,7 @@ let rec search_templates ids query = | Template id -> id :: ids ;; -let find_participation_experiments_of_query query = +let find_experiments_by_key expected_key query = let rec search ids query = let search_list ids = CCList.fold_left (fun ids predicate -> search ids predicate) ids @@ -400,7 +429,7 @@ let find_participation_experiments_of_query query = let open Key in (match[@warning "-4"] key with | Hardcoded key -> - if equal_hardcoded key Participation + if equal_hardcoded key expected_key then ( match value with | Lst values -> values @ ids diff --git a/pool/app/pool_common/locales/locales_en.ml b/pool/app/pool_common/locales/locales_en.ml index bf96f723c..b6ed1e7a9 100644 --- a/pool/app/pool_common/locales/locales_en.ml +++ b/pool/app/pool_common/locales/locales_en.ml @@ -518,8 +518,8 @@ let rec error_to_string = function | SessionNotStarted -> "This session cannot be closed, yet." | SessionRegistrationViaParent -> "Registration via main session." | SessionTenantNotFound -> - "Something on our side went wrong, please try again later or on multi \ - occurrences please contact the Administrator." + "Missing tenant: something on our side went wrong, please try again later \ + or on multi occurrences please contact the Administrator." | Smaller (field1, field2) -> Format.asprintf "%s smaller than %s" diff --git a/pool/run/dune b/pool/run/dune index 5d2f79777..9a21df894 100644 --- a/pool/run/dune +++ b/pool/run/dune @@ -1,4 +1,5 @@ (executable + (public_name run) (name run) (preprocess (pps lwt_ppx ppx_deriving.show)) diff --git a/pool/test/dune b/pool/test/dune index 31f7631e4..19f79e32b 100644 --- a/pool/test/dune +++ b/pool/test/dune @@ -1,5 +1,5 @@ (tests - (names command integration) + (names command integration filter_invitation_tests) (libraries admin alcotest diff --git a/pool/test/filter_invitation_tests.ml b/pool/test/filter_invitation_tests.ml new file mode 100644 index 000000000..df32f20e0 --- /dev/null +++ b/pool/test/filter_invitation_tests.ml @@ -0,0 +1,253 @@ +let ( let@ ) = Result.bind +let ( let* ) x f = Lwt_result.bind (Lwt_result.lift x) f +let ( let& ) = Lwt_result.bind +let test_db = Test_utils.Data.database_label + +let experiment () = + let open Experiment in + let experiment_id = Id.create () in + let* title = Title.create "an-experiment-title" in + let* public_title = PublicTitle.create "a-public-title" in + let direct_registration_disabled = DirectRegistrationDisabled.create false in + let registration_disabled = RegistrationDisabled.create false in + let allow_uninvited_singup = AllowUninvitedSignup.create false in + let external_data_required = ExternalDataRequired.create false in + let show_external_data_id_links = ShowExternalDataIdLinks.create false in + let* experiment = + Experiment.create + ~id:experiment_id + title + public_title + direct_registration_disabled + registration_disabled + allow_uninvited_singup + external_data_required + show_external_data_id_links + in + let experiment_created = + experiment |> Experiment.created |> Pool_event.experiment + in + let& () = + Pool_event.handle_event test_db experiment_created |> Lwt_result.ok + in + Experiment.find test_db experiment_id +;; + +let contact ~prefix () = + let open Contact in + let invited_contact_id = Id.create () in + let* email = + let email = + Format.asprintf "%s+%s@domain.test" prefix (Id.value invited_contact_id) + in + Pool_user.EmailAddress.create email + in + let* password = Pool_user.Password.create_unvalidated "a-password" in + let* firstname = Pool_user.Firstname.create "firstname" in + let* lastname = Pool_user.Lastname.create "lastname" in + let terms_accepted_at = + Pool_user.TermsAccepted.create (Ptime_clock.now ()) |> Option.some + in + let language = Pool_common.Language.En |> Option.some in + let contact_created = + [ Contact.created + { user_id = invited_contact_id + ; email + ; password + ; firstname + ; lastname + ; terms_accepted_at + ; language + } + |> Pool_event.contact + ] + in + let& () = Pool_event.handle_events test_db contact_created |> Lwt_result.ok in + let& contact = Contact.find test_db invited_contact_id in + let%lwt token = Email.create_token test_db email in + let* verification_events = + let open Cqrs_command.User_command in + let created_email = + Email.Created (email, token, invited_contact_id) + |> Pool_event.email_verification + in + let email = Email.create email contact.user token in + let@ verify_events = VerifyEmail.handle (Contact contact) email in + Ok (created_email :: verify_events) + in + let& () = + Pool_event.handle_events test_db verification_events |> Lwt_result.ok + in + let& contact = Contact.find test_db invited_contact_id in + let verification_events = + [ Contact.Verified contact |> Pool_event.contact ] + in + let& () = + Pool_event.handle_events test_db verification_events |> Lwt_result.ok + in + let& contact = Contact.find test_db invited_contact_id in + Lwt_result.lift (Ok contact) +;; + +let invitation ~experiment ~contacts = + let open Cqrs_command.Invitation_command in + let* events = + Create.( + handle + { experiment + ; contacts + ; invited_contacts = [] + ; create_message = + (fun _ -> + Sihl_email.create + ~sender:"sender" + ~recipient:"recipient" + ~subject:"subject" + "body" + |> Result.ok) + ; mailing = None + }) + in + let& () = Pool_event.handle_events test_db events |> Lwt_result.ok in + Lwt_result.lift (Ok ()) +;; + +(** This test verifies that given a contact that was invited to an experiment, + and one that was not, the contact that was not invited will show after the + invitation exclusion filter is applied. + + It does so by: + + 1. creating an experiment + 2. creating a contact that is invited to the experiment + 3. creating a contact that is NOT invited to the experiment + 4. create a filter that for invitations that includes our experiment + 5. assert on the found contacts + + Fin. *) +let finds_uninvited_contacts = + Test_utils.case + @@ fun () -> + (* 1. creating an experiment *) + let& experiment = experiment () in + (* 2. creating a contact that is invited to the experiment *) + let& invited_contact = contact ~prefix:"invited" () in + let& _invitation = invitation ~experiment ~contacts:[ invited_contact ] in + (* 3. creating a contact that is NOT invited to the experiment *) + let& expected_contact = contact ~prefix:"probe" () in + (* 4. create a filter that for invitations that includes our experiment *) + let invitation_filter = + let open Filter in + let key : Key.t = Key.(Hardcoded Invitation) in + let value = + let exp_ids = + [ Experiment.(experiment.id) ] + |> CCList.map Experiment.Id.value + |> CCList.map (fun value -> Filter.Str value) + in + Lst exp_ids + in + let operator = Operator.(List ListM.ContainsNone) in + let predicate = Predicate.create key operator value in + Filter.create None (Pred predicate) + in + let& found_contacts = + Filter.find_filtered_contacts + test_db + Filter.MatchesFilter + (Some invitation_filter) + in + (* FIXME(@leostera): since tests are not currently running in isolation, when + we search for things we may find a lot more than we care about. This little + filtering makes sure that we only ever return some of the users that we + have created. This is a HACK and we shoudl fix it by ensuring every test is + run in its own transaction. *) + let found_contacts = + CCList.filter + (fun contact -> + let open Contact in + let open Sihl_user in + contact.user.id = invited_contact.user.id + || contact.user.id = expected_contact.user.id) + found_contacts + in + (* 5. assert on the found contacts *) + Alcotest.( + check + int + "wrong number of contacts returned" + 1 + (CCList.length found_contacts)); + let actual_contact = CCList.hd found_contacts in + Alcotest.( + check + Test_utils.contact + "wrong contact retrieved" + expected_contact + actual_contact); + Lwt_result.lift (Ok ()) +;; + +(** This test verifies that given a contact that was invited to an experiment, + that contact is properly excluded by the filter. + + It does so by: + + 1. creating an experiment + 2. creating a contact that is invited to the experiment + 3. create a filter that for invitations that includes our experiment + 4. assert on the found contacts + + Fin. *) +let filters_out_invited_contacts = + Test_utils.case + @@ fun () -> + (* 1. creating an experiment *) + let& experiment = experiment () in + (* 2. creating a contact that is invited to the experiment *) + let& invited_contact = contact ~prefix:"invited" () in + let& _invitation = invitation ~experiment ~contacts:[ invited_contact ] in + (* 3. create a filter that for invitations that includes our experiment *) + let invitation_filter = + let open Filter in + let key : Key.t = Key.(Hardcoded Invitation) in + let value = + let exp_ids = + [ Experiment.(experiment.id) ] + |> CCList.map Experiment.Id.value + |> CCList.map (fun value -> Filter.Str value) + in + Lst exp_ids + in + let operator = Operator.(List ListM.ContainsNone) in + let predicate = Predicate.create key operator value in + Filter.create None (Pred predicate) + in + let& found_contacts = + Filter.find_filtered_contacts + test_db + Filter.MatchesFilter + (Some invitation_filter) + in + (* FIXME(@leostera): since tests are not currently running in isolation, when + we search for things we may find a lot more than we care about. This little + filtering makes sure that we only ever return some of the users that we + have created. This is a HACK and we shoudl fix it by ensuring every test is + run in its own transaction. *) + let found_contacts = + CCList.filter + (fun contact -> + let open Contact in + let open Sihl_user in + contact.user.id = invited_contact.user.id) + found_contacts + in + (* 4. assert on the found contacts *) + Alcotest.( + check + int + "wrong number of contacts returned" + 0 + (CCList.length found_contacts)); + Lwt_result.lift (Ok ()) +;; diff --git a/pool/test/integration.ml b/pool/test/integration.ml index b503e707a..a382c4823 100644 --- a/pool/test/integration.ml +++ b/pool/test/integration.ml @@ -225,6 +225,16 @@ let suite = `Slow AvailableExperiments.mark_assignment_as_deleted ] ) + ; ( "filtering" + , [ test_case + "uninvited contact is listed" + `Slow + Filter_invitation_tests.finds_uninvited_contacts + ; test_case + "invited contact is not listed" + `Slow + Filter_invitation_tests.filters_out_invited_contacts + ] ) ; ( "contact counter" , Contact_counter_test. [ test_case diff --git a/pool/test/test_utils.ml b/pool/test/test_utils.ml index 68dce1fed..b8c1afa81 100644 --- a/pool/test/test_utils.ml +++ b/pool/test/test_utils.ml @@ -548,10 +548,6 @@ module Repo = struct ;; end -(* NOTE(@leostera): here be dragons. This machinery gets rid of any resulting - value we have. It will fail a test if the underlying promise returns an - Error. *) let case fn (_switch : Lwt_switch.t) () : unit Lwt.t = - let result = Lwt_result.get_exn @@ Lwt_result.catch fn in - Lwt.map (fun _ -> ()) result + Lwt.map Pool_common.Utils.get_or_failwith (fn ()) ;;