Refactor guardian role query (#490)

* update collect_and_count in repositories * update related guardian models * rewrite experiment list queries * refactor location query * fix experiment search joins * consider user permissions when accessing contact page * apply user permissions to admins * extend admin test case by user permission * apply user permissions to calendar views * readd cleanup stage * undo routes change --------- Co-authored-by: Marc Biedermann <[email protected]>
uzh · Feb 17, 2025 · 8b46a35 · 8b46a35
1 parent 247f7bd
commit 8b46a35
Show file tree

Hide file tree

Showing 59 changed files with 872 additions and 445 deletions.
diff --git a/pool/app/admin/admin.ml b/pool/app/admin/admin.ml
@@ -48,5 +48,5 @@ module Repo = struct
   include Repo_entity
 
   let sql_select_columns = Repo.sql_select_columns
-  let joins = Repo.joins
+  let joins = Repo.user_join
 end
diff --git a/pool/app/admin/admin.mli b/pool/app/admin/admin.mli
@@ -17,6 +17,7 @@ val equal : t -> t -> bool
 val pp : Format.formatter -> t -> unit
 val show : t -> string
 val sexp_of_t : t -> Sexplib0.Sexp.t
+val compare : t -> t -> int
 val user : t -> Pool_user.t
 val create : email_verified:Pool_user.EmailVerified.t option -> Pool_user.t -> t
 val id : t -> Id.t
@@ -69,7 +70,13 @@ val find_by_email
   -> Pool_user.EmailAddress.t
   -> (t, Pool_message.Error.t) Lwt_result.t
 
-val find_by : ?query:Query.t -> Database.Label.t -> (t list * Query.t) Lwt.t
+val all : ?query:Query.t -> 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_with_role
   :  ?exclude:(Role.Role.t * Guard.Uuid.Target.t option) list

diff --git a/pool/app/admin/entity.ml b/pool/app/admin/entity.ml
@@ -27,6 +27,7 @@ let email_address ({ user; _ } : t) = user.Pool_user.email
 let sexp_of_t t = t |> id |> Id.sexp_of_t
 let fullname { user; _ } = Pool_user.fullname user
 let fullname_reversed { user; _ } = Pool_user.fullname ~reversed:true user
+let compare a b = Id.compare (id a) (id b)
 let filterable_by = None
 let searchable_by = Pool_user.searchable_by
 let sortable_by = Pool_user.sortable_by

diff --git a/pool/app/admin/repo.ml b/pool/app/admin/repo.ml
@@ -8,7 +8,7 @@ let sql_select_columns =
   @ [ "pool_admins.email_verified"; "pool_admins.import_pending" ]
 ;;
 
-let joins =
+let user_join =
   {sql|
     LEFT JOIN user_users
       ON pool_admins.user_uuid = user_users.uuid
@@ -32,11 +32,14 @@ let insert_request =
 
 let insert pool = Write.of_entity %> Database.exec pool insert_request
 
-let find_request_sql ?(count = false) =
+let find_request_sql ?(joins = []) ?(count = false) =
   let columns =
-    if count then "COUNT(*)" else sql_select_columns |> CCString.concat ", "
+    if count
+    then "COUNT(DISTINCT pool_admins.user_uuid)"
+    else sql_select_columns |> CCString.concat ", "
   in
-  Format.asprintf {sql|SELECT %s FROM pool_admins %s %s|sql} columns joins
+  let joins = user_join :: joins |> CCString.concat "\n" in
+  Format.asprintf {sql|SELECT DISTINCT %s FROM pool_admins %s %s|sql} columns joins
 ;;
 
 let find_request =
@@ -67,7 +70,20 @@ let find_all_request =
   {sql| WHERE user_users.admin = 1 |sql} |> find_request_sql |> Caqti_type.unit ->* t
 ;;
 
-let find_by ?query pool = Query.collect_and_count pool query ~select:find_request_sql t
+let all ?query pool =
+  Query.collect_and_count pool query ~select:(find_request_sql ?joins:None) t
+;;
+
+let list_by_user ?query pool actor =
+  let open CCFun.Infix in
+  let dyn, sql, joins =
+    Guard.Persistence.with_user_permission actor "pool_admins.user_uuid" `Admin
+  in
+  let select ?count =
+    find_request_sql ?count ~joins:[ joins ] %> Format.asprintf "%s %s" sql
+  in
+  Query.collect_and_count pool query ~select ~dyn Repo_entity.t
+;;
 
 let find_multiple_request ids =
   Format.asprintf
@@ -252,7 +268,7 @@ let search_by_name_and_email_request ?conditions =
   Format.asprintf
     "SELECT %s FROM pool_admins %s WHERE %s LIMIT %i"
     (sql_select_columns |> CCString.concat ", ")
-    joins
+    user_join
     where
 ;;
 

diff --git a/pool/app/assignment/repo/repo.ml b/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

diff --git a/pool/app/changelog/repo/repo.ml b/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 =

diff --git a/pool/app/contact/contact.ml b/pool/app/contact/contact.ml
@@ -4,6 +4,8 @@ include Repo
 include Entity
 include Event
 
+let list_by_user = Repo.list_by_user
+
 let find_by_user pool (user : Pool_user.t) =
   user.Pool_user.id |> Id.of_user |> Repo.find pool
 ;;

diff --git a/pool/app/contact/contact.mli b/pool/app/contact/contact.mli
@@ -88,6 +88,12 @@ val find : Database.Label.t -> Id.t -> (t, Pool_message.Error.t) Lwt_result.t
 val find_admin_comment : Database.Label.t -> Id.t -> AdminComment.t option Lwt.t
 val find_multiple : Database.Label.t -> Id.t list -> t list Lwt.t
 
+val list_by_user
+  :  ?query:Query.t
+  -> Database.Label.t
+  -> Guard.Actor.t
+  -> (t list * Query.t) Lwt.t
+
 val find_by_email
   :  Database.Label.t
   -> Pool_user.EmailAddress.t
@@ -98,14 +104,7 @@ val find_by_user
   -> Pool_user.t
   -> (t, Pool_message.Error.t) Lwt_result.t
 
-val find_all
-  :  ?query:Query.t
-  -> ?actor:Guard.Actor.t
-  -> ?permission:Guard.Permission.t
-  -> Database.Label.t
-  -> unit
-  -> (t list * Query.t) Lwt.t
-
+val all : ?query:Query.t -> Database.Label.t -> (t list * Query.t) Lwt.t
 val find_to_trigger_profile_update : Database.Label.t -> (t list, 'a) Lwt_result.t
 val should_send_registration_attempt_notification : Database.Label.t -> t -> bool Lwt.t
 
@@ -213,7 +212,14 @@ module Repo : sig
   val joins : string
   val sql_select_columns : string list
   val make_sql_select_columns : user_table:string -> contact_table:string -> string list
-  val find_request_sql : ?additional_joins:string list -> ?count:bool -> string -> string
+
+  val find_request_sql
+    :  ?distinct:bool
+    -> ?additional_joins:string list
+    -> ?count:bool
+    -> string
+    -> string
+
   val update_request : (Write.t, unit, [ `Zero ]) Caqti_request.t
 end
 

diff --git a/pool/app/contact/dune b/pool/app/contact/dune
@@ -22,6 +22,7 @@
    ppx_deriving.show
    ppx_fields_conv
    ppx_sexp_conv
+   ppx_string
    ppx_variants_conv
    ppx_yojson_conv)))
 

diff --git a/pool/app/contact/repo/repo.ml b/pool/app/contact/repo/repo.ml
@@ -44,10 +44,20 @@ let joins =
   |sql}
 ;;
 
-let find_request_sql ?(additional_joins = []) ?(count = false) where_fragment =
-  let columns = if count then "COUNT(*)" else CCString.concat ", " sql_select_columns in
+let find_request_sql
+      ?(distinct = true)
+      ?(additional_joins = [])
+      ?(count = false)
+      where_fragment
+  =
+  let columns =
+    if count
+    then "COUNT(DISTINCT user_users.uuid)"
+    else CCString.concat ", " sql_select_columns
+  in
   Format.asprintf
-    {sql|SELECT %s FROM pool_contacts %s %s|sql}
+    {sql|SELECT %s %s FROM pool_contacts %s %s|sql}
+    (if distinct && not count then "DISTINCT" else "")
     columns
     (joins :: additional_joins |> CCString.concat "\n")
     where_fragment
@@ -156,44 +166,87 @@ let select_count where_fragment =
   Format.asprintf "%s %s" select_from where_fragment
 ;;
 
-let find_all ?query ?actor ?permission pool () =
-  let checks =
-    [ Format.asprintf
-        {sql|
-          user_users.uuid IN (
-            SELECT contact_uuid FROM pool_sessions
-            JOIN pool_assignments ON pool_sessions.uuid = pool_assignments.session_uuid
-            WHERE pool_sessions.experiment_uuid IN %s
-            )
-        |sql}
-    ; Format.asprintf
-        {sql|
-          user_users.uuid IN (
-            SELECT contact_uuid FROM pool_assignments
-            WHERE pool_assignments.session_uuid IN %s
-            )
-        |sql}
-    ; Format.asprintf
-        {sql|
-          user_users.uuid IN (
-            SELECT contact_uuid FROM pool_sessions
-            JOIN pool_assignments ON pool_sessions.uuid = pool_assignments.session_uuid
-            WHERE pool_sessions.location_uuid IN %s
-            )
-        |sql}
-    ; Format.asprintf "user_users.uuid IN %s"
-    ]
+let list_by_user ?query pool actor =
+  let open CCFun.Infix in
+  let target_sql = CCFun.(Role.Target.show %> Format.asprintf "'%s'") in
+  let targets_to_sql targets = targets |> CCList.map target_sql |> CCString.concat "," in
+  (* Ignoring default permission joins *)
+  let dyn, sql, _ =
+    Guard.Persistence.with_user_permission actor "pool_experiments.uuid" `Contact
   in
-  let%lwt where =
-    Guard.create_where ?actor ?permission ~checks pool `Contact
-    ||> CCOption.map (fun m -> m, Dynparam.empty)
+  let contact_targets = targets_to_sql [ `Contact; `ContactInfo ] in
+  let joins =
+    [%string
+      {sql|
+        LEFT JOIN user_permissions 
+          ON pool_contacts.user_uuid = user_permissions.target_uuid
+          OR (
+            user_permissions.target_uuid IS NULL
+            AND user_permissions.target_model IN (%{contact_targets})
+          )
+    |sql}]
   in
-  Query.collect_and_count
-    pool
-    query
-    ~select:(find_request_sql ?additional_joins:None)
-    ?where
-    t
+  let join_assignment_with =
+    targets_to_sql [ `Assignment; `Session; `Experiment; `Location ]
+  in
+  let where =
+    [%string
+      {sql|
+        (
+          EXISTS (
+            SELECT
+              1
+            FROM
+              user_permissions
+            WHERE
+              (target_model = %{target_sql `Contact} AND target_uuid IS NULL)
+              OR target_uuid = pool_contacts.user_uuid
+          )
+          OR EXISTS (
+            SELECT
+              1
+            FROM
+              pool_assignments
+              INNER JOIN pool_sessions ON pool_sessions.uuid = pool_assignments.session_uuid
+              INNER JOIN user_permissions ON
+              (
+                -- ASSIGNMENT PERMISSION
+                user_permissions.target_uuid = pool_assignments.uuid 
+
+                -- SESSION PERMISSION
+                OR user_permissions.target_uuid = pool_sessions.uuid
+      
+                -- LOCATION PERMISSION
+                OR (
+                  pool_sessions.location_uuid IS NOT NULL
+                  AND pool_sessions.location_uuid = user_permissions.target_uuid
+                )
+
+                -- EXPERIMENT PERMISSION
+                OR user_permissions.target_uuid = pool_sessions.experiment_uuid
+
+                -- GLOBAL PERMISSIONS
+                OR (
+                  user_permissions.target_uuid IS NULL
+                  AND user_permissions.target_model IN (%{join_assignment_with})
+                )
+              )
+            WHERE
+              pool_assignments.contact_uuid = pool_contacts.user_uuid
+          )
+        )
+  |sql}]
+  in
+  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 ~where Repo_entity.t
+;;
+
+let all ?query pool =
+  let select = find_request_sql ~distinct:true ?additional_joins:None in
+  Query.collect_and_count pool query ~select t
 ;;
 
 let insert_request =