fix guardian access to settings pages (#430)

Co-authored-by: Timo Huber <timo.huber@econ.uzh.ch>

Author: timohuber

pool/pool_queue/entity_guard.ml

@@ -3,7 +3,7 @@ module Access = struct
   open ValidationSet
   open Permission
 
-  let index = one_of_tuple (Read, `Queue, None)
+  let index ?id () = one_of_tuple (Read, `Queue, id)
   let read = one_of_tuple (Read, `Queue, None)
   let resend = one_of_tuple (Create, `Queue, None)
 end

pool/web/handler/admin_contacts.ml

@@ -499,6 +499,8 @@ end = struct
   include Helpers.Access
   module Guardian = Middleware.Guardian
 
+  let contact_effects = Guardian.id_effects Contact.Id.of_string Field.Contact
+
   let index =
     Contact.Guard.Access.index |> Guardian.validate_admin_entity ~any_id:true
   ;;
@@ -545,6 +547,11 @@ end = struct
   let promote = Admin.Guard.Access.create |> Guardian.validate_admin_entity
 
   let message_history =
-    Pool_queue.Guard.Access.index |> Guardian.validate_admin_entity
+    (fun id ->
+      Pool_queue.Guard.Access.index
+        ~id:(Guard.Uuid.target_of Contact.Id.value id)
+        ())
+    |> contact_effects
+    |> Guardian.validate_generic
   ;;
 end

pool/web/handler/admin_experiments.ml

@@ -617,6 +617,11 @@ end = struct
   let search = index
 
   let message_history =
-    Pool_queue.Guard.Access.index |> Guardian.validate_admin_entity
+    (fun id ->
+      Pool_queue.Guard.Access.index
+        ~id:(Guard.Uuid.target_of Experiment.Id.value id)
+        ())
+    |> experiment_effects
+    |> Guardian.validate_generic
   ;;
 end

pool/web/handler/admin_filter.ml

@@ -356,7 +356,11 @@ module Access : module type of Helpers.Access = struct
   module Guardian = Middleware.Guardian
 
   let filter_effects = Guardian.id_effects Filter.Id.of_string Field.Filter
-  let index = Filter.Guard.Access.index |> Guardian.validate_admin_entity
+
+  let index =
+    Filter.Guard.Access.index |> Guardian.validate_admin_entity ~any_id:true
+  ;;
+
   let create = Command.Create.effects () |> Guardian.validate_admin_entity
 
   let update =

pool/web/handler/admin_organisational_units.ml

@@ -123,7 +123,8 @@ module Access : module type of Helpers.Access = struct
   ;;
 
   let index =
-    Organisational_unit.Guard.Access.index |> Guardian.validate_admin_entity
+    Organisational_unit.Guard.Access.index
+    |> Guardian.validate_admin_entity ~any_id:true
   ;;
 
   let create = Command.Create.effects |> Guardian.validate_admin_entity

pool/web/handler/admin_settings_queue.ml

@@ -74,7 +74,11 @@ end = struct
   include Helpers.Access
   module Guardian = Middleware.Guardian
 
-  let index = Pool_queue.Guard.Access.index |> Guardian.validate_admin_entity
+  let index =
+    Pool_queue.Guard.Access.index ()
+    |> Guardian.validate_admin_entity ~any_id:true
+  ;;
+
   let read = Pool_queue.Guard.Access.read |> Guardian.validate_admin_entity
   let resend = Command.Resend.effects |> Guardian.validate_admin_entity
 end

pool/web/handler/admin_settings_tags.ml

@@ -126,7 +126,11 @@ end = struct
   ;;
 
   let tag_effects = Guardian.id_effects Tags.Id.of_string Field.Tag
-  let index = Tags.Guard.Access.index |> Guardian.validate_admin_entity
+
+  let index =
+    Tags.Guard.Access.index |> Guardian.validate_admin_entity ~any_id:true
+  ;;
+
   let create = Command.Create.effects |> Guardian.validate_admin_entity
   let read = Tags.Guard.Access.read |> tag_effects |> Guardian.validate_generic
 

pool/web/view/layout/navigation.ml

@@ -85,7 +85,7 @@ module NavElements = struct
         ; single
             "/admin/settings/queue"
             Queue
-            (Set Pool_queue.Guard.Access.index)
+            (Set (Pool_queue.Guard.Access.index ()))
         ; single
             "/admin/settings"
             SystemSettings

pool/web/view/layout/navigation_experiment.ml

@@ -81,7 +81,10 @@ let nav_elements experiment =
               , Field Field.Experimenter
               , Set (Experimenter.read ~target_uuid ()) )
           ] )
-    ; Single (url "messages", MessageHistory, Set Pool_queue.Guard.Access.index)
+    ; Single
+        ( url "messages"
+        , MessageHistory
+        , Set (Pool_queue.Guard.Access.index ~id:target_uuid ()) )
     ]
   in
   left @ waiting_list_nav @ right |> CCList.map NavElement.create