diff --git a/pool/app/filter/entity.ml b/pool/app/filter/entity.ml index f50378b20..d129ee439 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"] + | Assignment [@printer print "assignment"] [@name "assignment"] | Invitation [@printer print "invitation"] [@name "invitation"] | Tag [@printer print "tag"] [@name "tag"] [@@deriving show { with_path = false }, eq, yojson, variants, enum] @@ -206,7 +207,7 @@ module Key = struct | NumNoShows -> Ok "pool_contacts.num_no_shows" | NumParticipations -> Ok "pool_contacts.num_participations" | NumShowUps -> Ok "pool_contacts.num_show_ups" - | Invitation | Participation | Tag -> + | Assignment | Invitation | Participation | Tag -> Error Pool_common.Message.(QueryNotCompatible (Field.Key, Field.Value)) ;; @@ -220,7 +221,7 @@ module Key = struct | NumNoShows | NumParticipations | NumShowUps -> Nr - | Invitation | Participation -> QueryExperiments + | Assignment | Invitation | Participation -> QueryExperiments | Tag -> QueryTags ;; @@ -532,7 +533,7 @@ module Operator = struct | NumNoShows | NumParticipations | NumShowUps -> all_equality_operators @ all_size_operators - | Participation | Tag | Invitation -> all_list_operators + | Participation | Tag | Invitation | Assignment -> 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 a20924ed4..f1a5c3a61 100644 --- a/pool/app/filter/filter.mli +++ b/pool/app/filter/filter.mli @@ -41,6 +41,7 @@ module Key : sig | NumParticipations | NumShowUps | Participation + | Assignment | Invitation | Tag diff --git a/pool/app/filter/repo/repo.ml b/pool/app/filter/repo/repo.ml index 6b6ce24e5..a7cbe9af9 100644 --- a/pool/app/filter/repo/repo.ml +++ b/pool/app/filter/repo/repo.ml @@ -198,6 +198,7 @@ module Sql = struct let queries = [ {sql| DROP TEMPORARY TABLE IF EXISTS tmp_participations; |sql} ; {sql| DROP TEMPORARY TABLE IF EXISTS tmp_invitations; |sql} + ; {sql| DROP TEMPORARY TABLE IF EXISTS tmp_assignments; |sql} ] in Lwt_list.map_s run_query queries @@ -239,7 +240,11 @@ module Sql = struct let create_request ids = Format.asprintf {sql| - CREATE TEMPORARY TABLE tmp_invitations AS ( + CREATE TEMPORARY TABLE tmp_invitations + (INDEX contact_index (contact_uuid), + INDEX experiment_index (experiment_uuid) + ) + AS ( SELECT pool_invitations.contact_uuid AS contact_uuid, pool_invitations.experiment_uuid AS experiment_uuid @@ -271,13 +276,60 @@ module Sql = struct fnc ;; + let create_temporary_assignments_table query = + let open Dynparam in + let open Caqti_request.Infix in + let create_request ids = + Format.asprintf + {sql| + CREATE TEMPORARY TABLE tmp_assignments + (INDEX contact_index (contact_uuid), + INDEX experiment_index (experiment_uuid) + ) + AS ( + SELECT + pool_assignments.contact_uuid AS contact_uuid, + pool_sessions.experiment_uuid AS experiment_uuid + FROM pool_assignments + INNER JOIN pool_sessions ON pool_sessions.uuid = pool_assignments.session_uuid + 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.Assignment + |> 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 let create_request ids = Format.asprintf {sql| - CREATE TEMPORARY TABLE tmp_participations AS ( + CREATE TEMPORARY TABLE tmp_participations + (INDEX contact_index (contact_uuid), + INDEX experiment_index (experiment_uuid) + ) + AS ( SELECT pool_assignments.contact_uuid AS contact_uuid, pool_sessions.experiment_uuid AS experiment_uuid @@ -313,6 +365,13 @@ module Sql = struct fnc ;; + let create_temp_tables filter = + [ create_temporary_participation_table filter + ; create_temporary_invitation_table filter + ; create_temporary_assignments_table filter + ] + ;; + let prepare_use_case_joins dyn = let open Dynparam in let invitation_join = @@ -340,11 +399,6 @@ 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_tables = - [ create_temporary_participation_table filter - ; create_temporary_invitation_table filter - ] - in let%lwt template_list = match filter with | None -> Lwt.return [] @@ -375,7 +429,7 @@ module Sql = struct in Utils.Database.find_as_transaction (pool |> Pool_database.Label.value) - ~setup:(drop_temp_table :: create_temp_tables) + ~setup:(drop_temp_table :: create_temp_tables filter) ~cleanup:[ drop_temp_table ] query ||> CCResult.return @@ -399,11 +453,6 @@ module Sql = struct where_fragment in let%lwt template_list = find_templates_of_query pool 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) @@ -422,7 +471,7 @@ module Sql = struct in Utils.Database.find_as_transaction (pool |> Pool_database.Label.value) - ~setup:(drop_temp_table :: create_temp_tables) + ~setup:(drop_temp_table :: create_temp_tables (Some query)) ~cleanup:[ drop_temp_table ] matches_filter_request ||> CCOption.map_or ~default (CCInt.equal 1) @@ -473,11 +522,6 @@ module Sql = struct let open Utils.Lwt_result.Infix in let open Caqti_request.Infix in let open Dynparam 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 [] @@ -490,13 +534,14 @@ module Sql = struct sql |> where_prefix |> count_filtered_request_sql use_case dyn in let request = prepared_request |> pt ->! Caqti_type.int in + let filter = query in let query connection = let (module Connection : Caqti_lwt.CONNECTION) = connection in Connection.find_opt request pv in Utils.Database.find_as_transaction (pool |> Pool_database.Label.value) - ~setup:(drop_temp_table :: create_temp_tables) + ~setup:(drop_temp_table :: create_temp_tables filter) ~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 c0d557dd8..dd8c3216d 100644 --- a/pool/app/filter/repo/repo_utils.ml +++ b/pool/app/filter/repo/repo_utils.ml @@ -176,6 +176,35 @@ let add_list_condition subquery dyn ids = Error Message.(Invalid Field.Operator) ;; +(* The subquery returns any contacts that has been an assignment to an + experiment. *) +let assignment_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_assignments.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_assignments + WHERE + tmp_assignments.contact_uuid = pool_contacts.user_uuid + AND tmp_assignments.experiment_uuid IN (%s) + |sql} + select + query_params + in + if count + then Format.asprintf "%s GROUP BY tmp_assignments.contact_uuid" base + else base + in + add_list_condition subquery dyn ids operator +;; + (* The subquery returns any contacts that has been invited to an experiment. *) let invitation_subquery dyn operator ids = let open CCResult in @@ -283,6 +312,7 @@ let predicate_to_sql (match hardcoded with | Participation -> participation_subquery dyn operator values | Invitation -> invitation_subquery dyn operator values + | Assignment -> assignment_subquery dyn operator values | Tag -> tag_subquery dyn operator values | ContactLanguage | Firstname diff --git a/pool/test/dune b/pool/test/dune index 19f79e32b..bef1330b7 100644 --- a/pool/test/dune +++ b/pool/test/dune @@ -1,5 +1,5 @@ (tests - (names command integration filter_invitation_tests) + (names command integration filter_invitation_tests filter_assignment_tests) (libraries admin alcotest diff --git a/pool/test/filter_assignment_tests.ml b/pool/test/filter_assignment_tests.ml new file mode 100644 index 000000000..b78707857 --- /dev/null +++ b/pool/test/filter_assignment_tests.ml @@ -0,0 +1,335 @@ +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 session ~experiment = + let open Session in + let sid = Id.create () in + let now = Ptime_clock.now () in + let session_start = Start.create now in + let* session_duration = + let one_day = Ptime.Span.of_int_s 86_400 in + let tomorrow = + Ptime.add_span now one_day + |> CCOption.get_exn_or "could not add one day to now" + in + Duration.create (Ptime.diff tomorrow now) + in + let pid = Pool_location.Id.create () in + let pool_address = Pool_location.Address.virtual_ in + let pool_status = Pool_location.Status.Active in + let mapping_file = [] in + let* pool_location = + Pool_location.create + ~id:pid + "a-pool-location" + None + pool_address + None + pool_status + mapping_file + in + let* max_participants = ParticipantAmount.create 2112 in + let* min_participants = ParticipantAmount.create 1984 in + let* overbook = ParticipantAmount.create 7 in + let session = + Session.create + ~id:sid + session_start + session_duration + pool_location + max_participants + min_participants + overbook + in + let events = + [ Pool_location.created pool_location |> Pool_event.pool_location + ; Session.Created (session, experiment.Experiment.id) |> Pool_event.session + ] + in + let& () = Pool_event.handle_events test_db events |> Lwt_result.ok in + Lwt_result.lift (Ok session) +;; + +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 user_id = Id.create () in + let* email = + let email = Format.asprintf "%s+%s@domain.test" prefix (Id.value user_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 + ; 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 user_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, user_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 user_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 user_id in + Lwt_result.lift (Ok contact) +;; + +let assignment ~experiment ~session ~contact = + let open Cqrs_command.Assignment_command in + let already_enrolled = false in + let* events = + Create.( + handle + { experiment; contact; follow_up_sessions = []; session } + (fun _ -> + Sihl_email.create + ~sender:"sender" + ~recipient:"recipient" + ~subject:"subject" + "body") + already_enrolled) + in + let& () = Pool_event.handle_events test_db events |> Lwt_result.ok in + Lwt_result.lift (Ok ()) +;; + +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 has accpeted an invitation to an experiment, + and one that was not, the contact that did not accept will show after the + assignment exclusion filter is applied. + + It does so by: + + 1. creating an experiment + 2. creating a contact that has accepted an invitation to the experiment + 3. creating a contact that has NOT accepted an invitation to the experiment + 4. create a filter that for assignments that includes our experiment + 5. assert on the found contacts + + Fin. *) +let finds_unassigned_contacts = + Test_utils.case + @@ fun () -> + (* 1. creating an experiment *) + let& experiment = experiment () in + (* 2. creating an session *) + let& session = session ~experiment in + (* 2. creating contacts *) + let& assigned_contact = contact ~prefix:"invited" () in + let& unassigned_contact = contact ~prefix:"probe" () in + (* 3. send invitations *) + let& _invitation = + invitation ~experiment ~contacts:[ assigned_contact; unassigned_contact ] + in + (* 4. only accept one of the invitations, creating the assignment *) + let& _assignment = + assignment ~experiment ~contact:assigned_contact ~session + in + (* 5. create a filter that for assignments that includes our experiment *) + let assignment_filter = + let open Filter in + let key : Key.t = Key.(Hardcoded Assignment) 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 assignment_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 = unassigned_contact.user.id + || contact.user.id = assigned_contact.user.id) + found_contacts + in + (* 6. assert on the found contacts *) + let& expected_contact = + Contact.find test_db (Contact.id unassigned_contact) + in + 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 has accepted an invitation to the experiment + 3. create a filter that for assignments that includes our experiment + 4. assert on the found contacts + + Fin. *) +let filters_out_assigned_contacts = + Test_utils.case + @@ fun () -> + (* 1. creating an experiment *) + let& experiment = experiment () in + (* 2. creating an session *) + let& session = session ~experiment in + (* 2. creating a contact that is invited to the experiment *) + let& assigned_contact = contact ~prefix:"invited" () in + let& _invitation = invitation ~experiment ~contacts:[ assigned_contact ] in + (* 4. only accept one of the invitations, creating the assignment *) + let& _assignment = + assignment ~experiment ~contact:assigned_contact ~session + in + (* 3. create a filter that for assignments that includes our experiment *) + let assignment_filter = + let open Filter in + let key : Key.t = Key.(Hardcoded Assignment) 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 assignment_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 = assigned_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 a382c4823..e3d7cc345 100644 --- a/pool/test/integration.ml +++ b/pool/test/integration.ml @@ -234,6 +234,14 @@ let suite = "invited contact is not listed" `Slow Filter_invitation_tests.filters_out_invited_contacts + ; test_case + "unassigned contact is listed" + `Slow + Filter_assignment_tests.finds_unassigned_contacts + ; test_case + "assigned contact is not listed" + `Slow + Filter_assignment_tests.filters_out_assigned_contacts ] ) ; ( "contact counter" , Contact_counter_test.