Refactor guardian role query

pool/app/assignment/repo/repo.ml

@@ -149,16 +149,10 @@ module Sql = struct
   ;;
 
   let query_by_session ?query pool id =
-    let where =
-      ( "pool_assignments.session_uuid = UNHEX(REPLACE(?, '-', ''))"
-      , Dynparam.(empty |> add Session.Repo.Id.t id) )
-    in
-    Query.collect_and_count
-      pool
-      query
-      ~select:(find_request_sql ?additional_joins:None)
-      ~where
-      t
+    let where = "pool_assignments.session_uuid = UNHEX(REPLACE(?, '-', ''))" in
+    let dyn = Dynparam.(empty |> add Session.Repo.Id.t id) in
+    let select = find_request_sql ?additional_joins:None in
+    Query.collect_and_count pool query ~select ~where ~dyn t
   ;;
 
   let find_deleted_by_session_request () =
@@ -253,7 +247,7 @@ module Sql = struct
     let open Caqti_request.Infix in
     Format.asprintf
       {sql|
-        SELECT 
+        SELECT
           %s
         FROM pool_assignments
           %s
@@ -423,7 +417,7 @@ module Sql = struct
 
   let find_by_contact_to_merge_request =
     let open Caqti_request.Infix in
-    {sql| 
+    {sql|
       WHERE contact_uuid = UNHEX(REPLACE($1, '-', ''))
       AND NOT EXISTS (
         SELECT 1

pool/app/changelog/repo/repo.ml

@@ -25,13 +25,9 @@ let find_request_sql ?(count = false) =
 
 let find_by_model ?query pool entity_uuid =
   let open Repo_entity in
-  let where =
-    ( {sql| 
-        pool_change_log.entity_uuid = UNHEX(REPLACE($1, '-', ''))
-      |sql}
-    , Dynparam.(empty |> add RepoId.t entity_uuid) )
-  in
-  Query.collect_and_count pool query ~select:find_request_sql ~where t
+  let where = {sql| pool_change_log.entity_uuid = UNHEX(REPLACE($1, '-', '')) |sql} in
+  let dyn = Dynparam.(empty |> add RepoId.t entity_uuid) in
+  Query.collect_and_count pool query ~select:find_request_sql ~where ~dyn t
 ;;
 
 let insert_request =

pool/app/contact/repo/repo.ml

@@ -184,16 +184,9 @@ let find_all ?query ?actor ?permission pool () =
     ; Format.asprintf "user_users.uuid IN %s"
     ]
   in
-  let%lwt where =
-    Guard.create_where ?actor ?permission ~checks pool `Contact
-    ||> CCOption.map (fun m -> m, Dynparam.empty)
-  in
-  Query.collect_and_count
-    pool
-    query
-    ~select:(find_request_sql ?additional_joins:None)
-    ?where
-    t
+  let%lwt where = Guard.create_where ?actor ?permission ~checks pool `Contact in
+  let select = find_request_sql ?additional_joins:None in
+  Query.collect_and_count pool query ~select ?where t
 ;;
 
 let insert_request =

pool/app/duplicate_contacts/repo.ml

@@ -36,7 +36,7 @@ let similarity_request user_columns custom_field_columns similarities average =
   let columns = user_columns @ custom_field_columns |> CCString.concat "," in
   let similarities = similarities |> CCString.concat "," in
   let contact_joins =
-    {sql| 
+    {sql|
       INNER JOIN user_users ON pool_contacts.user_uuid = user_users.uuid
       LEFT JOIN pool_custom_field_answers ON pool_contacts.user_uuid = pool_custom_field_answers.entity_uuid
     |sql}
@@ -50,7 +50,7 @@ let similarity_request user_columns custom_field_columns similarities average =
         FROM
           pool_contacts
         %{contact_joins}
-        WHERE 
+        WHERE
           pool_contacts.email_verified IS NOT NULL
           AND pool_contacts.disabled = 0
         GROUP BY user_users.uuid
@@ -80,7 +80,7 @@ let similarity_request user_columns custom_field_columns similarities average =
         CAST(similarity_score AS FLOAT)
       FROM
         average_similarity
-      WHERE 
+      WHERE
         similarity_score >= $2
       ORDER BY
         similarity_score DESC;
@@ -137,9 +137,9 @@ let find_similars database_label ~user_uuid custom_fields =
     let id = id field |> Id.value in
     asprintf
       {sql| MAX(
-        CASE WHEN pool_custom_field_answers.custom_field_uuid = %s 
-        THEN COALESCE(pool_custom_field_answers.admin_value, pool_custom_field_answers.value) 
-        END) AS %s 
+        CASE WHEN pool_custom_field_answers.custom_field_uuid = %s
+        THEN COALESCE(pool_custom_field_answers.admin_value, pool_custom_field_answers.value)
+        END) AS %s
       |sql}
       (id |> asprintf "\"%s\"" |> id_value_fragment)
       (asprintf "`%s`" id)
@@ -185,11 +185,11 @@ let insert_request =
   Format.asprintf
     {sql|
     INSERT INTO pool_contacts_possible_duplicates (
-      uuid, 
-      contact_a, 
+      uuid,
+      contact_a,
       contact_b,
       score
-    ) VALUES 
+    ) VALUES
       %s
     ON DUPLICATE KEY UPDATE
       score = VALUES(score),
@@ -245,17 +245,14 @@ let find pool id =
 
 let find_by_contact ?query pool contact =
   let where =
-    let open Contact in
-    let sql =
-      {sql|
-        pool_contacts_possible_duplicates.contact_a = UNHEX(REPLACE($1, '-', ''))
-          OR 
-        pool_contacts_possible_duplicates.contact_b = UNHEX(REPLACE($1, '-', ''))
-      |sql}
-    in
-    sql, Dynparam.(empty |> add Repo.Id.t (id contact))
+    {sql|
+      pool_contacts_possible_duplicates.contact_a = UNHEX(REPLACE($1, '-', ''))
+        OR
+      pool_contacts_possible_duplicates.contact_b = UNHEX(REPLACE($1, '-', ''))
+    |sql}
   in
-  Query.collect_and_count pool query ~where ~select:find_request_sql Repo_entity.t
+  let dyn = Dynparam.(empty |> add Contact.Repo.Id.t (Contact.id contact)) in
+  Query.collect_and_count pool query ~where ~dyn ~select:find_request_sql Repo_entity.t
 ;;
 
 let all ?query pool =
@@ -266,12 +263,12 @@ let ingore_request =
   let open Caqti_request.Infix in
   Format.asprintf
     {sql|
-      UPDATE 
+      UPDATE
         pool_contacts_possible_duplicates
       SET
         `ignore` = 1
       WHERE
-        uuid = UNHEX(REPLACE($1, '-', '')) 
+        uuid = UNHEX(REPLACE($1, '-', ''))
     |sql}
   |> Repo_entity.Id.t ->. Caqti_type.unit
 ;;
@@ -288,9 +285,9 @@ let find_to_check pool =
           %s
         FROM pool_contacts
           %s
-        WHERE 
+        WHERE
           (duplicates_last_checked IS NULL
-            OR 
+            OR
           duplicates_last_checked < NOW() - INTERVAL 1 WEEK)
           AND disabled = 0
         ORDER BY duplicates_last_checked IS NULL DESC, duplicates_last_checked ASC

pool/app/email/repo/repo_sql.ml

@@ -256,12 +256,11 @@ module Smtp = struct
   ;;
 
   let find_by query pool =
-    Query.collect_and_count
-      pool
-      (Some query)
-      ~select:(fun ?(count = false) fragment ->
-        if count then select_count fragment else select_smtp_sql fragment)
-      RepoEntity.SmtpAuth.t
+    let select =
+      fun ?(count = false) fragment ->
+      if count then select_count fragment else select_smtp_sql fragment
+    in
+    Query.collect_and_count pool (Some query) ~select RepoEntity.SmtpAuth.t
   ;;
 
   let unset_default_flags pool =

pool/app/experiment/experiment.ml

@@ -19,6 +19,7 @@ end
 
 let find = Repo.find
 let find_all = Repo.find_all
+let list_by_user = Repo.Sql.list_by_user
 let find_all_ids_of_contact_id = Repo.find_all_ids_of_contact_id
 let find_public = Repo_public.find
 let find_full_by_contact = Repo_public.find_full_by_contact

pool/app/experiment/experiment.mli

@@ -267,6 +267,12 @@ val find_all
   -> Database.Label.t
   -> (t list * Query.t) Lwt.t
 
+val list_by_user
+  :  ?query:Query.t
+  -> Database.Label.t
+  -> Guard.Actor.t
+  -> (t list * Query.t) Lwt.t
+
 val find_all_ids_of_contact_id : Database.Label.t -> Contact.Id.t -> Id.t list Lwt.t
 
 val find_public

pool/app/experiment/repo/repo.ml

@@ -208,18 +208,22 @@ module Sql = struct
   let validate_experiment_sql m = Format.asprintf " AND %s " m, Dynparam.empty
 
   let find_all ?query ?actor ?permission pool =
-    let open Utils.Lwt_result.Infix in
     let checks = [ Format.asprintf "pool_experiments.uuid IN %s" ] in
-    let%lwt where =
-      Guard.create_where ?actor ?permission ~checks pool `Experiment
-      ||> CCOption.map (fun m -> m, Dynparam.empty)
+    let%lwt where = Guard.create_where ?actor ?permission ~checks pool `Experiment in
+    let select = find_request_sql ~distinct:true ~additional_joins:joins_tags in
+    Query.collect_and_count pool query ~select ?where Repo_entity.t
+  ;;
+
+  let list_by_user ?query pool actor =
+    let open CCFun.Infix in
+    let dyn, sql, joins =
+      Guard.Persistence.with_user_permission actor "pool_experiments.uuid" `Experiment
     in
-    Query.collect_and_count
-      pool
-      query
-      ~select:(find_request_sql ~distinct:true ~additional_joins:joins_tags)
-      ?where
-      Repo_entity.t
+    let select ?count =
+      find_request_sql ?count ~distinct:true ~additional_joins:joins
+      %> Format.asprintf "%s %s" sql
+    in
+    Query.collect_and_count pool query ~select ~dyn Repo_entity.t
   ;;
 
   let find_request =
@@ -564,20 +568,16 @@ module Sql = struct
         |sql}
         (if only_closed then Format.asprintf "AND (%s)" only_closed_condition else "")
     in
-    Dynparam.(where, dyn |> add Contact.Repo.Id.t contact_id), joins
+    where, Dynparam.(dyn |> add Contact.Repo.Id.t contact_id), joins
   ;;
 
   let query_participation_history_by_contact ?query pool contact =
-    let contact_id = Contact.id contact in
-    let where, additional_joins =
-      participation_history_where ~only_closed:false contact_id
+    let where, dyn, additional_joins =
+      Contact.id contact |> participation_history_where ~only_closed:false
     in
-    Query.collect_and_count
-      pool
-      query
-      ~select:(participation_history_sql additional_joins)
-      ~where
-      Caqti_type.(t2 Repo_entity.t bool)
+    let select = participation_history_sql additional_joins in
+    Caqti_type.(t2 Repo_entity.t bool)
+    |> Query.collect_and_count pool query ~select ~where ~dyn
   ;;
 
   let count_invitations_request ?(by_count = false) () =

pool/app/experiment/repo/repo_public.ml

@@ -29,7 +29,7 @@ let select_from_experiments_sql ?(distinct = false) where_fragment =
 
 let pool_sessions_inner_join =
   {sql|
-    INNER JOIN pool_sessions 
+    INNER JOIN pool_sessions
     ON pool_sessions.experiment_uuid = pool_experiments.uuid
   |sql}
 ;;
@@ -91,7 +91,7 @@ let find_upcoming_to_register_request experiment_type () =
   let timewindow_exists =
     {sql|
       (DATE_ADD(pool_sessions.start, INTERVAL pool_sessions.duration SECOND) > NOW()
-        AND 
+        AND
       pool_sessions.canceled_at IS NULL)
     |sql}
   in
@@ -117,7 +117,7 @@ let find_upcoming_to_register_request experiment_type () =
         pool_waiting_list.contact_uuid = UNHEX(REPLACE($1, '-', ''))
       AND
         pool_waiting_list.experiment_uuid = pool_experiments.uuid
-      AND 
+      AND
         pool_waiting_list.marked_as_deleted = 0
       )
       |sql}
@@ -193,7 +193,7 @@ let find_pending_waitinglists_by_contact pool contact =
 
 let find_past_experiments_by_contact pool contact =
   let open Caqti_request.Infix in
-  let (where, Dynparam.Pack (pt, pv)), joins =
+  let where, Dynparam.Pack (pt, pv), joins =
     Repo.Sql.participation_history_where ~only_closed:true (Contact.id contact)
   in
   let request =
@@ -215,7 +215,7 @@ let where_contact_can_access =
   |sql}
   in
   let waiting_list_exists =
-    {sql| 
+    {sql|
       (pool_waiting_list.contact_uuid = UNHEX(REPLACE($1, '-', ''))
       AND pool_waiting_list.marked_as_deleted = 0)
       |sql}

pool/app/filter/repo/repo.ml

@@ -79,13 +79,9 @@ module Sql = struct
   let find_all_templates pool = Database.collect pool find_all_templates_request
 
   let find_templates_by query pool =
-    let where = template_condition, Dynparam.empty in
-    Query.collect_and_count
-      pool
-      (Some query)
-      ~select:(find_request_sql ~joins:joins_experiment)
-      ~where
-      Repo_entity.t
+    let select = find_request_sql ~joins:joins_experiment in
+    let where = template_condition in
+    Query.collect_and_count pool (Some query) ~select ~where Repo_entity.t
   ;;
 
   let find_multiple_request ids =

pool/app/guard/guard.ml

@@ -222,6 +222,7 @@ let create_where
       model
   =
   let open Utils.Lwt_result.Infix in
+  let open Pool_message in
   let tags = Database.Logger.Tags.create pool in
   let log_warning = Pool_common.Utils.with_log_error ~src ~level:Logs.Warning ~tags in
   match actor, permission with
@@ -235,10 +236,10 @@ let create_where
        |> CCOption.return
      | None -> all)
   | None, Some _ ->
-    let _ = log_warning Pool_message.(Error.Undefined Field.Actor) in
+    let (_ : Error.t) = log_warning (Error.Undefined Field.Actor) in
     Lwt.return_some "FALSE"
   | Some _, None ->
-    let _ = log_warning Pool_message.(Error.Undefined Field.Permission) in
+    let (_ : Error.t) = log_warning (Error.Undefined Field.Permission) in
     Lwt.return_some "FALSE"
   | None, None -> Lwt.return_none
 ;;