Implement filter by participation experiment tags

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
+    | QueryExperimentTags
   [@@deriving show]
 
   type hardcoded =
@@ -120,6 +121,7 @@ module Key = struct
     | Assignment [@printer print "assignment"] [@name "assignment"]
     | Invitation [@printer print "invitation"] [@name "invitation"]
     | Tag [@printer print "tag"] [@name "tag"]
+    | ExperimentTag [@printer print "experiment_tag"] [@name "experiment_tag"]
   [@@deriving show { with_path = false }, eq, yojson, variants, enum]
 
   type human =
@@ -197,7 +199,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 | ExperimentTag ->
       Error Pool_message.(Error.QueryNotCompatible (Field.Key, Field.Value))
   ;;
 
@@ -209,6 +211,7 @@ module Key = struct
     | NumAssignments | NumInvitations | NumNoShows | NumParticipations | NumShowUps -> Nr
     | Assignment | Invitation | Participation -> QueryExperiments
     | Tag -> QueryTags
+    | ExperimentTag -> QueryExperimentTags
   ;;
 
   let type_of_custom_field m : input_type =
@@ -245,7 +248,7 @@ module Key = struct
           options
         |> CCOption.to_result error
         >|= CCFun.const ()
-      | Str _, (QueryExperiments | QueryTags) -> Ok ()
+      | Str _, (QueryExperiments | QueryTags | QueryExperimentTags) -> Ok ()
       | _ -> Error error
     in
     let validate value input_type =
@@ -507,15 +510,16 @@ 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 | ExperimentTag | Invitation | Assignment -> all_list_operators
   ;;
 
   let input_type_to_operator (key : Key.input_type) =
     let open Key in
     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 | QueryExperimentTags ->
+      all_list_operators
     | Select _ -> all_select_operators
     | Str -> all_equality_operators @ all_string_operators
   ;;

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_experiment_tags =
+  let open Entity.Key in
+  all_in_query_fcn (function
+    | Some (Hardcoded ExperimentTag), Some (Entity.Lst lst) ->
+      lst |> Filter_utils.single_val_to_id |> CCList.map Tags.Id.of_common
+    | _, _ -> [])
+;;

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_experiment_tags =
+  let open Entity.Key in
+  all_in_query_fcn (function
+    | Hardcoded ExperimentTag, Entity.Lst lst ->
+      lst |> Filter_utils.single_val_to_id |> CCList.map Tags.Id.of_common
+    | _, _ -> [])
+;;

pool/app/filter/filter.mli

@@ -28,6 +28,7 @@ module Key : sig
     | MultiSelect of Custom_field.SelectOption.t list
     | QueryExperiments
     | QueryTags
+    | QueryExperimentTags
 
   val show_input_type : input_type -> string
 
@@ -44,6 +45,7 @@ module Key : sig
     | Assignment
     | Invitation
     | Tag
+    | ExperimentTag
 
   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_experiment_tags : 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_experiment_tags : t -> Tags.Id.t list
 
 type base_condition =
   | MatchesFilter

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.ExperimentTag 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
     ]
   ;;
 

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 experiment_tag_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
+        | ExperimentTag -> experiment_tag_subquery dyn operator values
         | ContactLanguage
         | Firstname
         | Name

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

pool/web/handler/admin_experiments_invitations.ml

@@ -17,15 +17,20 @@ 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_experiment_tags =
       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_experiment_tags =
+          filter |> Filter.all_query_experiment_tags |> Tags.find_multiple database_label
+        in
+        Lwt.return (query_experiments, query_tags, query_experiment_tags)
     in
     let* filtered_contacts =
       if Sihl.Configuration.is_production ()
@@ -51,6 +56,7 @@ let index req =
       template_list
       query_experiments
       query_tags
+      query_experiment_tags
       statistics
       filtered_contacts
       context

pool/web/handler/admin_filter.ml

@@ -67,18 +67,29 @@ 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_experiment_tags =
       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_experiment_tags =
+          filter |> Filter.all_query_experiment_tags |> Tags.find_multiple database_label
+        in
+        Lwt.return (query_experiments, query_tags, query_experiment_tags)
     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_experiment_tags
     |> create_layout req context
     >|+ Sihl.Web.Response.of_html
   in
@@ -180,12 +191,14 @@ 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_experiment_tags =
+      query |> Filter.Human.all_query_experiment_tags |> Tags.find_multiple database_label
     in
     Component.Filter.(
       predicate_form
@@ -194,8 +207,9 @@ let handle_toggle_predicate_type action req =
         key_list
         template_list
         templates_disabled
-        quey_experiments
+        query_experiments
         query_tags
+        query_experiment_tags
         (Some query)
         ~identifier
         ())
@@ -214,7 +228,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 +259,7 @@ let handle_add_predicate action req =
         templates_disabled
         []
         []
+        []
         query
         ~identifier
         ()

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

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