diff --git a/pool/app/filter/entity.ml b/pool/app/filter/entity.ml index 5db9b9bcc..bc7eeab57 100644 --- a/pool/app/filter/entity.ml +++ b/pool/app/filter/entity.ml @@ -105,6 +105,7 @@ module Key = struct | MultiSelect of Custom_field.SelectOption.t list [@printer print "multi_select"] | QueryExperiments | QueryTags + | QueryTaggedExperiments [@@deriving show] type hardcoded = @@ -120,6 +121,8 @@ module Key = struct | Assignment [@printer print "assignment"] [@name "assignment"] | Invitation [@printer print "invitation"] [@name "invitation"] | Tag [@printer print "tag"] [@name "tag"] + | TaggedParticipation [@printer print "tagged_participation"] + [@name "tagged_participation"] [@@deriving show { with_path = false }, eq, yojson, variants, enum] type human = @@ -197,7 +200,7 @@ module Key = struct | NumNoShows -> Ok "pool_contacts.num_no_shows" | NumParticipations -> Ok "pool_contacts.num_participations" | NumShowUps -> Ok "pool_contacts.num_show_ups" - | Assignment | Invitation | Participation | Tag -> + | Assignment | Invitation | Participation | Tag | TaggedParticipation -> Error Pool_message.(Error.QueryNotCompatible (Field.Key, Field.Value)) ;; @@ -209,6 +212,7 @@ module Key = struct | NumAssignments | NumInvitations | NumNoShows | NumParticipations | NumShowUps -> Nr | Assignment | Invitation | Participation -> QueryExperiments | Tag -> QueryTags + | TaggedParticipation -> QueryTaggedExperiments ;; let type_of_custom_field m : input_type = @@ -245,7 +249,7 @@ module Key = struct options |> CCOption.to_result error >|= CCFun.const () - | Str _, (QueryExperiments | QueryTags) -> Ok () + | Str _, (QueryExperiments | QueryTags | QueryTaggedExperiments) -> Ok () | _ -> Error error in let validate value input_type = @@ -507,7 +511,8 @@ module Operator = struct | Firstname | Name -> all_equality_operators @ all_string_operators | NumAssignments | NumInvitations | NumNoShows | NumParticipations | NumShowUps -> all_equality_operators @ all_size_operators - | Participation | Tag | Invitation | Assignment -> all_list_operators + | Participation | Tag | TaggedParticipation | Invitation | Assignment -> + all_list_operators ;; let input_type_to_operator (key : Key.input_type) = @@ -515,7 +520,8 @@ module Operator = struct match key with | Bool | Languages _ -> all_equality_operators | Date | Nr -> all_equality_operators @ all_size_operators - | MultiSelect _ | QueryExperiments | QueryTags -> all_list_operators + | MultiSelect _ | QueryExperiments | QueryTags | QueryTaggedExperiments -> + all_list_operators | Select _ -> all_select_operators | Str -> all_equality_operators @ all_string_operators ;; diff --git a/pool/app/filter/entity_human.ml b/pool/app/filter/entity_human.ml index 3287d920d..f0fc4aed2 100644 --- a/pool/app/filter/entity_human.ml +++ b/pool/app/filter/entity_human.ml @@ -105,3 +105,11 @@ let[@warning "-4"] all_query_tags = lst |> Filter_utils.single_val_to_id |> CCList.map Tags.Id.of_common | _, _ -> []) ;; + +let[@ocaml.warning "-4"] all_query_tagged_experiments = + let open Entity.Key in + all_in_query_fcn (function + | Some (Hardcoded TaggedParticipation), Some (Entity.Lst lst) -> + lst |> Filter_utils.single_val_to_id |> CCList.map Tags.Id.of_common + | _, _ -> []) +;; diff --git a/pool/app/filter/filter.ml b/pool/app/filter/filter.ml index 38a70514b..d63d2c69e 100644 --- a/pool/app/filter/filter.ml +++ b/pool/app/filter/filter.ml @@ -113,3 +113,11 @@ let[@warning "-4"] all_query_tags = lst |> Filter_utils.single_val_to_id |> CCList.map Tags.Id.of_common | _, _ -> []) ;; + +let[@ocaml.warning "-4"] all_query_tagged_experiments = + let open Entity.Key in + all_in_query_fcn (function + | Hardcoded TaggedParticipation, Entity.Lst lst -> + lst |> Filter_utils.single_val_to_id |> CCList.map Tags.Id.of_common + | _, _ -> []) +;; diff --git a/pool/app/filter/filter.mli b/pool/app/filter/filter.mli index 8d0fc73c9..8cb2caa22 100644 --- a/pool/app/filter/filter.mli +++ b/pool/app/filter/filter.mli @@ -28,6 +28,7 @@ module Key : sig | MultiSelect of Custom_field.SelectOption.t list | QueryExperiments | QueryTags + | QueryTaggedExperiments val show_input_type : input_type -> string @@ -44,6 +45,7 @@ module Key : sig | Assignment | Invitation | Tag + | TaggedParticipation type t = | CustomField of Custom_field.Id.t @@ -164,6 +166,7 @@ module Human : sig val of_yojson : Key.human list -> Yojson.Safe.t -> (t, Pool_message.Error.t) result val all_query_experiments : t -> Pool_common.Id.t list val all_query_tags : t -> Tags.Id.t list + val all_query_tagged_experiments : t -> Tags.Id.t list end val equal : t -> t -> bool @@ -239,6 +242,7 @@ val find_templates_of_query : Database.Label.t -> query -> t list Lwt.t val toggle_predicate_type : Human.t -> string -> (Human.t, Pool_message.Error.t) result val all_query_experiments : t -> Pool_common.Id.t list val all_query_tags : t -> Tags.Id.t list +val all_query_tagged_experiments : t -> Tags.Id.t list type base_condition = | MatchesFilter diff --git a/pool/app/filter/repo/repo.ml b/pool/app/filter/repo/repo.ml index 1d1913620..f6235dacd 100644 --- a/pool/app/filter/repo/repo.ml +++ b/pool/app/filter/repo/repo.ml @@ -188,6 +188,7 @@ module Sql = struct in let queries = [ {sql| DROP TEMPORARY TABLE IF EXISTS tmp_participations; |sql} + ; {sql| DROP TEMPORARY TABLE IF EXISTS tmp_tagged_participations; |sql} ; {sql| DROP TEMPORARY TABLE IF EXISTS tmp_invitations; |sql} ; {sql| DROP TEMPORARY TABLE IF EXISTS tmp_assignments; |sql} ] @@ -360,11 +361,61 @@ module Sql = struct fnc ;; + let create_temporary_tagged_participation_table template_queries query = + let open Dynparam in + let open Caqti_request.Infix in + let create_request ids = + Format.asprintf + {sql| + CREATE TEMPORARY TABLE tmp_tagged_participations + (INDEX contact_index (contact_uuid), + INDEX tag_index (tag_uuid) + ) + AS ( + SELECT + pool_assignments.contact_uuid AS contact_uuid, + pool_tagging.tag_uuid AS tag_uuid + FROM + pool_assignments + INNER JOIN pool_sessions ON pool_sessions.uuid = pool_assignments.session_uuid + INNER JOIN pool_tagging ON pool_tagging.model_uuid = pool_sessions.experiment_uuid + AND pool_assignments.participated = 1 + AND pool_assignments.canceled_at IS NULL + AND pool_tagging.tag_uuid IN ( %s )) + |sql} + (CCList.mapi + (fun i _ -> Format.asprintf "UNHEX(REPLACE($%n, '-', ''))" (i + 1)) + ids + |> CCString.concat ",") + in + let fnc connection = + match query with + | None -> Lwt_result.return () + | Some query -> + query :: template_queries + |> CCList.fold_left + (fun acc cur -> + acc @ Repo_utils.find_experiments_by_key Key.TaggedParticipation cur) + [] + |> (function + | [] -> Lwt_result.return () + | 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_temp_tables templates filter = let template_queries = CCList.map (fun f -> f.query) templates in [ create_temporary_participation_table template_queries filter ; create_temporary_invitation_table template_queries filter ; create_temporary_assignments_table template_queries filter + ; create_temporary_tagged_participation_table template_queries filter ] ;; diff --git a/pool/app/filter/repo/repo_utils.ml b/pool/app/filter/repo/repo_utils.ml index b7e68a695..1fabe688d 100644 --- a/pool/app/filter/repo/repo_utils.ml +++ b/pool/app/filter/repo/repo_utils.ml @@ -283,6 +283,33 @@ let tag_subquery dyn operator ids = add_list_condition subquery dyn ids operator ;; +let tagged_participation_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_tagged_participations.tag_uuid" in + let select = if count then Format.asprintf "COUNT(%s)" col else col in + let base = + Format.asprintf + {sql| + SELECT + %s + FROM + tmp_tagged_participations + WHERE + tmp_tagged_participations.contact_uuid = pool_contacts.user_uuid + AND tmp_tagged_participations.tag_uuid in (%s) + |sql} + select + query_params + in + if count + then Format.asprintf "%s GROUP BY tmp_participations.contact_uuid" base + else base + in + add_list_condition subquery dyn ids operator +;; + let predicate_to_sql (dyn, sql) ({ Predicate.key; operator; value } : Predicate.t) = let open CCResult in let open Operator in @@ -308,6 +335,7 @@ let predicate_to_sql (dyn, sql) ({ Predicate.key; operator; value } : Predicate. | Invitation -> invitation_subquery dyn operator values | Assignment -> assignment_subquery dyn operator values | Tag -> tag_subquery dyn operator values + | TaggedParticipation -> tagged_participation_subquery dyn operator values | ContactLanguage | Firstname | Name diff --git a/pool/routes/routes.ml b/pool/routes/routes.ml index 513b0db1f..608fd40d2 100644 --- a/pool/routes/routes.ml +++ b/pool/routes/routes.ml @@ -885,6 +885,7 @@ module Admin = struct ; get "/create" ~middlewares:[ Access.create ] new_form ; post "" ~middlewares:[ Access.create ] create ; post "/search" ~middlewares:[ Access.search ] search + ; post "/search-experiment" ~middlewares:[ Access.search ] search_experiment_tags ; choose ~scope:(Tag |> url_key) specific ] in diff --git a/pool/web/handler/admin_experiments_invitations.ml b/pool/web/handler/admin_experiments_invitations.ml index 2ee4f5cfd..ad4c8b4e7 100644 --- a/pool/web/handler/admin_experiments_invitations.ml +++ b/pool/web/handler/admin_experiments_invitations.ml @@ -17,15 +17,22 @@ let index req = let common_exp_id = Experiment.(experiment |> id |> Id.to_common) in let%lwt key_list = Filter.all_keys database_label in let%lwt template_list = Filter.find_all_templates database_label () in - let%lwt query_experiments, query_tags = + let%lwt query_experiments, query_tags, query_tagged_experiments = match experiment |> Experiment.filter with - | None -> Lwt.return ([], []) + | None -> Lwt.return ([], [], []) | Some filter -> - Lwt.both - (filter - |> Filter.all_query_experiments - |> Experiment.search_multiple_by_id database_label) - (filter |> Filter.all_query_tags |> Tags.find_multiple database_label) + let%lwt query_experiments = + filter + |> Filter.all_query_experiments + |> Experiment.search_multiple_by_id database_label + and query_tags = + filter |> Filter.all_query_tags |> Tags.find_multiple database_label + and query_tagged_experiments = + filter + |> Filter.all_query_tagged_experiments + |> Tags.find_multiple database_label + in + Lwt.return (query_experiments, query_tags, query_tagged_experiments) in let* filtered_contacts = if Sihl.Configuration.is_production () @@ -51,6 +58,7 @@ let index req = template_list query_experiments query_tags + query_tagged_experiments statistics filtered_contacts context diff --git a/pool/web/handler/admin_filter.ml b/pool/web/handler/admin_filter.ml index f506d89b2..222b63699 100644 --- a/pool/web/handler/admin_filter.ml +++ b/pool/web/handler/admin_filter.ml @@ -67,18 +67,31 @@ let form is_edit req = in Response.bad_request_render_error context @@ - let%lwt query_experiments, query_tags = + let%lwt query_experiments, query_tags, query_tagged_experiments = match filter with - | None -> Lwt.return ([], []) + | None -> Lwt.return ([], [], []) | Some filter -> - Lwt.both - (filter - |> Filter.all_query_experiments - |> Experiment.search_multiple_by_id database_label) - (filter |> Filter.all_query_tags |> Tags.find_multiple database_label) + let%lwt query_experiments = + filter + |> Filter.all_query_experiments + |> Experiment.search_multiple_by_id database_label + and query_tags = + filter |> Filter.all_query_tags |> Tags.find_multiple database_label + and query_tagged_experiments = + filter + |> Filter.all_query_tagged_experiments + |> Tags.find_multiple database_label + in + Lwt.return (query_experiments, query_tags, query_tagged_experiments) in let%lwt key_list = Filter.all_keys database_label in - Page.Admin.Filter.edit context filter key_list query_experiments query_tags + Page.Admin.Filter.edit + context + filter + key_list + query_experiments + query_tags + query_tagged_experiments |> create_layout req context >|+ Sihl.Web.Response.of_html in @@ -180,12 +193,16 @@ let handle_toggle_predicate_type action req = Filter.toggle_predicate_type current predicate_type in let* identifier = find_identifier urlencoded |> Lwt_result.lift in - let%lwt quey_experiments, query_tags = - Lwt.both - (query - |> Filter.Human.all_query_experiments - |> Experiment.search_multiple_by_id database_label) - (query |> Filter.Human.all_query_tags |> Tags.find_multiple database_label) + let%lwt query_experiments = + query + |> Filter.Human.all_query_experiments + |> Experiment.search_multiple_by_id database_label + and query_tags = + query |> Filter.Human.all_query_tags |> Tags.find_multiple database_label + and query_tagged_experiments = + query + |> Filter.Human.all_query_tagged_experiments + |> Tags.find_multiple database_label in Component.Filter.( predicate_form @@ -194,8 +211,9 @@ let handle_toggle_predicate_type action req = key_list template_list templates_disabled - quey_experiments + query_experiments query_tags + query_tagged_experiments (Some query) ~identifier ()) @@ -214,7 +232,7 @@ let handle_toggle_key _ req = |> Lwt_result.lift >>= Filter.key_of_string database_label in - Component.Filter.predicate_value_form language [] [] ~key () + Component.Filter.predicate_value_form language [] [] [] ~key () |> Response.Htmx.of_html |> Lwt.return_ok in @@ -245,6 +263,7 @@ let handle_add_predicate action req = templates_disabled [] [] + [] query ~identifier () diff --git a/pool/web/handler/admin_settings_tags.ml b/pool/web/handler/admin_settings_tags.ml index e809696a9..bca39d4c5 100644 --- a/pool/web/handler/admin_settings_tags.ml +++ b/pool/web/handler/admin_settings_tags.ml @@ -93,6 +93,7 @@ let write action req = let create = write `Create let update req = write (`Update (id req)) req let search = Helpers.Search.htmx_search_helper `ContactTag +let search_experiment_tags = Helpers.Search.htmx_search_helper `ExperimentTag let changelog req = let id = id req in diff --git a/pool/web/handler/helpers_search.ml b/pool/web/handler/helpers_search.ml index d91333cb1..e47a04e51 100644 --- a/pool/web/handler/helpers_search.ml +++ b/pool/web/handler/helpers_search.ml @@ -53,12 +53,17 @@ let htmx_search_helper validate database_label (read id) actor ||> CCResult.is_ok) in execute_search search_location query_results - | `ContactTag -> + | (`ContactTag | `ExperimentTag) as model_tag -> let open Component.Search.Tag in let open Tags.Guard.Access in let%lwt exclude = entities_to_exclude Tags.Id.of_string in + let model = + match model_tag with + | `ContactTag -> Tags.Model.Contact + | `ExperimentTag -> Tags.Model.Experiment + in let search_tags value actor = - Tags.search_by_title database_label ~model:Tags.Model.Contact ~exclude value + Tags.search_by_title database_label ~model ~exclude value >|> Lwt_list.filter_s (fun (id, _) -> validate database_label (read id) actor ||> CCResult.is_ok) in diff --git a/pool/web/view/component/component_filter.ml b/pool/web/view/component/component_filter.ml index ae02a3862..f87ae9d9c 100644 --- a/pool/web/view/component/component_filter.ml +++ b/pool/web/view/component/component_filter.ml @@ -49,6 +49,7 @@ let value_input language query_experiments query_tags + query_tagged_experiments input_type ?(disabled = false) ?value @@ -231,10 +232,40 @@ let value_input | Bool _ | Date _ | Language _ | Nr _ | Option _ -> None) lst) in - Component_search.Tag.filter_multi_search ~selected ~disabled language ()) + Component_search.Tag.filter_multi_search ~selected ~disabled language () + | Key.QueryTaggedExperiments -> + let selected = + value + |> CCOption.map_or ~default:[] (function + | NoValue | Single _ -> [] + | Lst lst -> + CCList.filter_map + (function + | Str id -> + let tag_id = id |> Tags.Id.of_string in + CCList.find_opt + (fun (id, _) -> Tags.Id.equal id tag_id) + query_tagged_experiments + | Bool _ | Date _ | Language _ | Nr _ | Option _ -> None) + lst) + in + Component_search.TaggedExperiment.filter_multi_search + ~selected + ~disabled + language + ()) ;; -let predicate_value_form language query_experiments query_tags ?key ?value ?operator () = +let predicate_value_form + language + query_experiments + query_tags + query_tagged_experiments + ?key + ?value + ?operator + () + = let open CCOption.Infix in let input_type = key >|= Filter.Key.type_of_key in let operators = key >|= Filter.Operator.operators_of_key in @@ -247,6 +278,7 @@ let predicate_value_form language query_experiments query_tags ?key ?value ?oper language query_experiments query_tags + query_tagged_experiments input_type ~disabled:value_disabled ?value @@ -263,6 +295,7 @@ let single_predicate_form templates_disabled query_experiments query_tags + query_tagged_experiments ?key ?operator ?value @@ -270,7 +303,15 @@ let single_predicate_form = let toggle_id = Utils.format_identifiers ~prefix:"pred-s" identifier in let toggled_content = - predicate_value_form language query_experiments query_tags ?key ?value ?operator () + predicate_value_form + language + query_experiments + query_tags + query_tagged_experiments + ?key + ?value + ?operator + () in let key_selector = let attributes = @@ -365,6 +406,7 @@ let rec predicate_form templates_disabled query_experiments query_tags + query_tagged_experiments query ?(identifier = [ 0 ]) () @@ -394,6 +436,7 @@ let rec predicate_form templates_disabled query_experiments query_tags + query_tagged_experiments in let open Human in match query with @@ -419,6 +462,7 @@ let rec predicate_form templates_disabled query_experiments query_tags + query_tagged_experiments ?key ?operator ?value @@ -477,6 +521,7 @@ let filter_form template_list query_experiments query_tags + query_tagged_experiments = let filter, action = let open Experiment in @@ -558,6 +603,7 @@ let filter_form templates_disabled query_experiments query_tags + query_tagged_experiments filter_query () in diff --git a/pool/web/view/component/component_search.ml b/pool/web/view/component/component_search.ml index 630ce4052..28283e04e 100644 --- a/pool/web/view/component/component_search.ml +++ b/pool/web/view/component/component_search.ml @@ -260,6 +260,43 @@ module Tag = struct ;; end +module TaggedExperiment = struct + open Tags + + let placeholder = "Search by experiment tag title" + let to_label = snd %> Title.value + let to_value = fst %> Id.value + + let create ?disabled ?hints ?is_filter ?tag_name ?(selected = []) language = + let dynamic_search = + { hx_url = "/admin/settings/tags/search-experiment" + ; hx_method = `Post + ; to_label + ; to_value + ; selected + } + in + multi_search + ?disabled + ?hints + ?is_filter + ~placeholder + ?tag_name + language + Field.Tag + (Dynamic dynamic_search) + ;; + + let filter_multi_search ~selected ~disabled language = + create ~disabled ~is_filter:true ~selected ~tag_name:Pool_message.Field.Value language + ;; + + let query_results language items = + CCList.map (default_query_results_item ~to_label ~to_value) items + |> with_empty_message language + ;; +end + module RoleTarget = struct let hx_url base_path target_id = Format.asprintf "%s/%s/search-role" base_path (Guard.Uuid.Target.to_string target_id) diff --git a/pool/web/view/page/page_admin_experiments.ml b/pool/web/view/page/page_admin_experiments.ml index 6490b3da2..6146b8e01 100644 --- a/pool/web/view/page/page_admin_experiments.ml +++ b/pool/web/view/page/page_admin_experiments.ml @@ -939,6 +939,7 @@ let invitations template_list query_experiments query_tags + query_tagged_experiments statistics filtered_contacts ({ Pool_context.language; _ } as context) @@ -972,6 +973,7 @@ let invitations template_list query_experiments query_tags + query_tagged_experiments filtered_contacts statistics ; changelog diff --git a/pool/web/view/page/page_admin_filter.ml b/pool/web/view/page/page_admin_filter.ml index 989774f25..de7b2bac9 100644 --- a/pool/web/view/page/page_admin_filter.ml +++ b/pool/web/view/page/page_admin_filter.ml @@ -61,6 +61,7 @@ let edit key_list query_experiments query_tags + query_tagged_experiments = let changelog = match filter with @@ -85,7 +86,8 @@ let edit key_list [] query_experiments - query_tags) + query_tags + query_tagged_experiments) ; changelog ] ] diff --git a/pool/web/view/page/page_admin_invitations.ml b/pool/web/view/page/page_admin_invitations.ml index fc079a69c..07a76c739 100644 --- a/pool/web/view/page/page_admin_invitations.ml +++ b/pool/web/view/page/page_admin_invitations.ml @@ -98,6 +98,7 @@ module Partials = struct template_list query_experiments query_tags + query_tagged_experiments filtered_contacts statistics = @@ -167,7 +168,8 @@ module Partials = struct key_list template_list query_experiments - query_tags) + query_tags + query_tagged_experiments) ; div ~a:[ a_class [ "gap-lg" ] ] [ filtered_contacts_form ] ] ;;