Feature/1824 checkbox filter

CHANGELOG.md

@@ -4,6 +4,10 @@ The format is based on [Keep a Changelog](http://keepachangelog.com/) and this p
 
 ## [unreleased](https://github.com/uzh/pool/tree/HEAD)
 
+### Changed
+- use multi select in filter form for select custom fields
+- standardize the creation of search components
+
 ## [0.4.8](https://github.com/uzh/pool/tree/0.4.8) - 2023-10-24
 
 ### Added

pool/app/experiment/experiment.ml

@@ -44,6 +44,7 @@ let search = Repo.search
 let search_multiple_by_id = Repo.search_multiple_by_id
 let find_to_enroll_directly = Repo.find_to_enroll_directly
 let contact_is_enrolled = Repo.contact_is_enrolled
+let find_targets_grantable_by_admin = Repo.find_targets_grantable_by_admin
 let possible_participant_count _ = Lwt.return 0
 let possible_participants _ = Lwt.return []
 

pool/app/experiment/experiment.mli

@@ -241,8 +241,12 @@ val find_past_experiments_by_contact
 val session_count : Pool_database.Label.t -> Id.t -> int Lwt.t
 
 val search
-  :  Pool_database.Label.t
-  -> Id.t list
+  :  ?conditions:string
+  -> ?dyn:Utils.Database.Dynparam.t
+  -> ?exclude:Id.t list
+  -> ?joins:string
+  -> ?limit:int
+  -> Pool_database.Label.t
   -> string
   -> (Id.t * Title.t) list Lwt.t
 
@@ -264,6 +268,14 @@ val contact_is_enrolled
   -> Contact.Id.t
   -> bool Lwt.t
 
+val find_targets_grantable_by_admin
+  :  ?exclude:Id.t list
+  -> Pool_database.Label.t
+  -> Admin.t
+  -> Role.Role.t
+  -> string
+  -> (Id.t * Title.t) list Lwt.t
+
 val possible_participant_count : t -> int Lwt.t
 val possible_participants : t -> Contact.t list Lwt.t
 val title_value : t -> string

pool/app/experiment/repo/repo.ml

@@ -158,6 +158,21 @@ module Sql = struct
     Format.asprintf "%s %s" select_from where_fragment
   ;;
 
+  let search_select =
+    {sql|
+        SELECT
+          LOWER(CONCAT(
+            SUBSTR(HEX(pool_experiments.uuid), 1, 8), '-',
+            SUBSTR(HEX(pool_experiments.uuid), 9, 4), '-',
+            SUBSTR(HEX(pool_experiments.uuid), 13, 4), '-',
+            SUBSTR(HEX(pool_experiments.uuid), 17, 4), '-',
+            SUBSTR(HEX(pool_experiments.uuid), 21)
+          )),
+          pool_experiments.title
+        FROM pool_experiments
+    |sql}
+  ;;
+
   let validate_experiment_sql m = Format.asprintf " AND %s " m, Dynparam.empty
 
   let select_count where_fragment =
@@ -305,72 +320,62 @@ module Sql = struct
       (id |> Entity.Id.value)
   ;;
 
-  let search_request ?(limit = 20) ids =
-    let base =
-      {sql|
-        SELECT
-          LOWER(CONCAT(
-            SUBSTR(HEX(pool_experiments.uuid), 1, 8), '-',
-            SUBSTR(HEX(pool_experiments.uuid), 9, 4), '-',
-            SUBSTR(HEX(pool_experiments.uuid), 13, 4), '-',
-            SUBSTR(HEX(pool_experiments.uuid), 17, 4), '-',
-            SUBSTR(HEX(pool_experiments.uuid), 21)
-          )),
-          pool_experiments.title
-        FROM pool_experiments
-        WHERE pool_experiments.title LIKE $1
-      |sql}
+  let search_request ?conditions ?joins ~limit () =
+    let default_contidion = "pool_experiments.title LIKE ?" in
+    let joined_select =
+      CCOption.map_or
+        ~default:search_select
+        (Format.asprintf "%s %s" search_select)
+        joins
     in
-    let query =
-      match ids with
-      | [] -> base
-      | ids ->
-        CCList.mapi
-          (fun i _ -> Format.asprintf "UNHEX(REPLACE($%i, '-', ''))" (i + 2))
-          ids
-        |> CCString.concat ","
-        |> Format.asprintf
-             {sql|
-              %s
-              AND pool_experiments.uuid NOT IN (%s)
-          |sql}
-             base
+    let where =
+      CCOption.map_or
+        ~default:default_contidion
+        (Format.asprintf "%s AND %s" default_contidion)
+        conditions
     in
-    Format.asprintf "%s LIMIT %i" query limit
+    Format.asprintf "%s WHERE %s LIMIT %i" joined_select where limit
   ;;
 
-  let search pool exclude query =
+  let search
+    ?conditions
+    ?(dyn = Dynparam.empty)
+    ?exclude
+    ?joins
+    ?(limit = 20)
+    pool
+    query
+    =
     let open Caqti_request.Infix in
-    let dyn =
-      CCList.fold_left
-        (fun dyn id ->
-          dyn |> Dynparam.add Caqti_type.string (id |> Entity.Id.value))
-        Dynparam.(empty |> add Caqti_type.string ("%" ^ query ^ "%"))
-        exclude
+    let exclude_ids =
+      Utils.Database.exclude_ids "pool_experiments.uuid" Entity.Id.value
+    in
+    let dyn = Dynparam.(dyn |> add Caqti_type.string ("%" ^ query ^ "%")) in
+    let dyn, exclude =
+      exclude |> CCOption.map_or ~default:(dyn, None) (exclude_ids dyn)
+    in
+    let conditions =
+      [ conditions; exclude ]
+      |> CCList.filter_map CCFun.id
+      |> function
+      | [] -> None
+      | conditions -> conditions |> CCString.concat " AND " |> CCOption.return
     in
     let (Dynparam.Pack (pt, pv)) = dyn in
     let request =
-      search_request exclude
-      |> pt ->* Caqti_type.(Repo_entity.(tup2 Repo_entity.Id.t Title.t))
+      search_request ?conditions ?joins ~limit ()
+      |> pt ->* Repo_entity.(Caqti_type.tup2 Id.t Title.t)
     in
-    Utils.Database.collect (pool |> Database.Label.value) request pv
+    Utils.Database.collect (pool |> Pool_database.Label.value) request pv
   ;;
 
   let search_multiple_by_id_request ids =
     Format.asprintf
       {sql|
-        SELECT
-          LOWER(CONCAT(
-            SUBSTR(HEX(pool_experiments.uuid), 1, 8), '-',
-            SUBSTR(HEX(pool_experiments.uuid), 9, 4), '-',
-            SUBSTR(HEX(pool_experiments.uuid), 13, 4), '-',
-            SUBSTR(HEX(pool_experiments.uuid), 17, 4), '-',
-            SUBSTR(HEX(pool_experiments.uuid), 21)
-          )),
-          pool_experiments.title
-        FROM pool_experiments
+        %s
         WHERE pool_experiments.uuid in ( %s )
       |sql}
+      search_select
       (CCList.map (fun _ -> Format.asprintf "UNHEX(REPLACE(?, '-', ''))") ids
        |> CCString.concat ",")
   ;;
@@ -524,6 +529,24 @@ module Sql = struct
       contact_is_enrolled_request
       (experiment_id |> Entity.Id.value, contact_id |> Contact.Id.value)
   ;;
+
+  let find_targets_grantable_by_admin ?exclude database_label admin role query =
+    let joins =
+      {sql|
+      LEFT JOIN guardian_actor_role_targets t ON t.target_uuid = pool_experiments.uuid
+        AND t.actor_uuid = UNHEX(REPLACE(?, '-', ''))
+        AND t.role = ?
+    |sql}
+    in
+    let conditions = "t.role IS NULL" in
+    let dyn =
+      Dynparam.(
+        empty
+        |> add Caqti_type.string Admin.(id admin |> Id.value)
+        |> add Caqti_type.string Role.Role.(show role))
+    in
+    search ~conditions ~joins ~dyn ?exclude database_label query
+  ;;
 end
 
 let find = Sql.find
@@ -539,3 +562,4 @@ let search = Sql.search
 let search_multiple_by_id = Sql.search_multiple_by_id
 let find_to_enroll_directly = Sql.find_to_enroll_directly
 let contact_is_enrolled = Sql.contact_is_enrolled
+let find_targets_grantable_by_admin = Sql.find_targets_grantable_by_admin

pool/app/filter/entity.ml

@@ -371,6 +371,7 @@ module Operator = struct
     [@@deriving show { with_path = false }, eq, enum, yojson]
 
     let all = generate_all min max of_enum
+    let single_select_operators = [ ContainsSome; ContainsNone ]
     let json_key = "List"
 
     let read yojson =
@@ -482,6 +483,7 @@ module Operator = struct
   let all_string_operators = StringM.all >|= string
   let all_size_operators = Size.all >|= size
   let all_list_operators = ListM.all >|= list
+  let all_select_operators = ListM.single_select_operators >|= list
   let all_existence_operators = Existence.all >|= existence
 
   let all =
@@ -536,9 +538,10 @@ module Operator = struct
   let input_type_to_operator (key : Key.input_type) =
     let open Key in
     match key with
-    | Bool | Languages _ | Select _ -> all_equality_operators
+    | Bool | Languages _ -> all_equality_operators
     | Date | Nr -> all_equality_operators @ all_size_operators
     | MultiSelect _ | QueryExperiments | QueryTags -> all_list_operators
+    | Select _ -> all_select_operators
     | Str -> all_equality_operators @ all_string_operators
   ;;
 
@@ -604,9 +607,9 @@ module Predicate = struct
     match yojson with
     | `Assoc assoc ->
       let open CCResult in
-      let go key of_yojson =
+      let go json_key of_yojson =
         assoc
-        |> CCList.assoc_opt ~eq:CCString.equal key
+        |> CCList.assoc_opt ~eq:CCString.equal json_key
         |> CCOption.map of_yojson
       in
       let* key = go key_string Key.of_yojson |> to_result Message.Field.Key in

pool/app/pool_location/pool_location.ml

@@ -9,3 +9,4 @@ let find_all = Repo.find_all
 let find_location_file = Repo_file_mapping.find
 let search = Repo.search
 let search_multiple_by_id = Repo.search_multiple_by_id
+let find_targets_grantable_by_admin = Repo.find_targets_grantable_by_admin

pool/app/pool_location/pool_location.mli

@@ -289,8 +289,12 @@ val find_location_file
   -> (Mapping.file, Entity.Message.error) result Lwt.t
 
 val search
-  :  Pool_database.Label.t
-  -> Id.t list
+  :  ?conditions:string
+  -> ?dyn:Utils.Database.Dynparam.t
+  -> ?exclude:Id.t list
+  -> ?joins:string
+  -> ?limit:int
+  -> Pool_database.Label.t
   -> string
   -> (Id.t * Name.t) list Lwt.t
 
@@ -299,6 +303,13 @@ val search_multiple_by_id
   -> Id.t list
   -> (Id.t * Name.t) list Lwt.t
 
+val find_targets_grantable_by_admin
+  :  ?exclude:Id.t list
+  -> Pool_database.Label.t
+  -> Admin.t
+  -> string
+  -> (Id.t * Name.t) list Lwt.t
+
 val default_values : t list
 
 module Human : sig