Bug/2143 validate uuids (#438)

* validate router params in middleware * rewrite id effect middlewares to catch invalid uuids * rewrite combned middlewares * move denied middleware to bottom * rewrite experiment user middleware * remove _result from middleware function names --------- Co-authored-by: Timo Huber <[email protected]>
uzh · Sep 16, 2024 · 3868b53 · 3868b53
1 parent 005514b
commit 3868b53
Show file tree

Hide file tree

Showing 26 changed files with 205 additions and 491 deletions.
diff --git a/pool/pool_model/base.ml b/pool/pool_model/base.ml
@@ -7,6 +7,14 @@ module Id = struct
 
   let create () = Uuidm.v `V4 |> Uuidm.to_string
   let of_string m = m
+
+  let validate m =
+    m
+    |> Uuidm.of_string
+    |> CCOption.to_result Pool_message.Error.(Invalid Pool_message.Field.Id)
+    |> CCResult.map Uuidm.to_string
+  ;;
+
   let value m = m
   let to_common m = m
   let of_common m = m
@@ -47,6 +55,7 @@ module type IdSig = sig
   val yojson_of_t : t -> Yojson.Safe.t
   val create : unit -> t
   val of_string : string -> t
+  val validate : string -> (t, Pool_message.Error.t) result
   val value : t -> string
   val to_common : t -> t
   val of_common : t -> t

diff --git a/pool/routes/routes.ml b/pool/routes/routes.ml
@@ -276,8 +276,8 @@ module Admin = struct
         [ get "" ~middlewares:[ Session.Access.read_by_location ] Session.show ]
       in
       let specific =
-        [ get "" ~middlewares:[ Access.index ] show
-        ; get "/statistics" ~middlewares:[ Access.index ] statistics
+        [ get "" ~middlewares:[ Access.read ] show
+        ; get "/statistics" ~middlewares:[ Access.read ] statistics
         ; get "/edit" ~middlewares:[ Access.update ] edit
         ; post "" ~middlewares:[ Access.update ] update
         ; choose ~scope:"/files" files

diff --git a/pool/web/handler/admin_admins.ml b/pool/web/handler/admin_admins.ml
@@ -307,23 +307,15 @@ end = struct
   module Command = Cqrs_command.Admin_command
   module Guardian = Middleware.Guardian
 
-  let admin_effects = Guardian.id_effects Admin.Id.of_string Field.Admin
+  let admin_effects = Guardian.id_effects Admin.Id.validate Field.Admin
 
   let index =
     Admin.Guard.Access.index |> Guardian.validate_admin_entity ~any_id:true
   ;;
 
   let create = Command.CreateAdmin.effects |> Guardian.validate_admin_entity
-
-  let read =
-    Admin.Guard.Access.read |> admin_effects |> Guardian.validate_generic
-  ;;
-
-  let update =
-    Admin.Guard.Access.update
-    |> admin_effects
-    |> Middleware.Guardian.validate_generic
-  ;;
+  let read = admin_effects Admin.Guard.Access.read
+  let update = admin_effects Admin.Guard.Access.update
 
   let grant_role =
     Command.GrantRoles.effects |> Middleware.Guardian.validate_admin_entity

diff --git a/pool/web/handler/admin_contacts.ml b/pool/web/handler/admin_contacts.ml
@@ -499,7 +499,7 @@ end = struct
   include Helpers.Access
   module Guardian = Middleware.Guardian
 
-  let contact_effects = Guardian.id_effects Contact.Id.of_string Field.Contact
+  let contact_effects = Guardian.id_effects Contact.Id.validate Field.Contact
 
   let index =
     Contact.Guard.Access.index |> Guardian.validate_admin_entity ~any_id:true
@@ -528,7 +528,7 @@ end = struct
           |> CCList.map one_of_tuple)
       |> or_
       |> Lwt.return_ok)
-    |> Guardian.validate_generic_lwt_result
+    |> Guardian.validate_generic_lwt
   ;;
 
   let read =
@@ -547,11 +547,9 @@ end = struct
   let promote = Admin.Guard.Access.create |> Guardian.validate_admin_entity
 
   let message_history =
-    (fun id ->
+    contact_effects (fun id ->
       Pool_queue.Guard.Access.index
         ~id:(Guard.Uuid.target_of Contact.Id.value id)
         ())
-    |> contact_effects
-    |> Guardian.validate_generic
   ;;
 end
diff --git a/pool/web/handler/admin_custom_field_groups.ml b/pool/web/handler/admin_custom_field_groups.ml
@@ -198,31 +198,20 @@ end = struct
   module Guardian = Middleware.Guardian
 
   let custom_field_group_effects =
-    Guardian.id_effects Custom_field.Group.Id.of_string Field.CustomFieldGroup
+    Guardian.id_effects Custom_field.Group.Id.validate Field.CustomFieldGroup
   ;;
 
   let create = Command.Create.effects |> Guardian.validate_admin_entity
-
-  let update =
-    Command.Update.effects
-    |> custom_field_group_effects
-    |> Guardian.validate_generic
-  ;;
-
+  let update = custom_field_group_effects Command.Update.effects
   let sort = Command.Sort.effects |> Guardian.validate_admin_entity
 
   let sort_fields =
-    (fun req ->
+    custom_field_group_effects (fun goup_id ->
       Guard.ValidationSet.And
         [ Cqrs_command.Custom_field_command.Sort.effects
-        ; custom_field_group_effects Custom_field.Guard.Access.Group.update req
+        ; Custom_field.Guard.Access.Group.update goup_id
         ])
-    |> Guardian.validate_generic
   ;;
 
-  let delete =
-    Command.Destroy.effects
-    |> custom_field_group_effects
-    |> Guardian.validate_generic
-  ;;
+  let delete = custom_field_group_effects Command.Destroy.effects
 end
diff --git a/pool/web/handler/admin_custom_field_options.ml b/pool/web/handler/admin_custom_field_options.ml
@@ -188,29 +188,15 @@ end = struct
   module CustomFieldCommand = Cqrs_command.Custom_field_option_command
 
   let custom_field_effects =
-    Middleware.Guardian.id_effects Custom_field.Id.of_string Field.CustomField
+    Middleware.Guardian.id_effects Custom_field.Id.validate Field.CustomField
   ;;
 
   let create =
     CustomFieldCommand.Create.effects
     |> Middleware.Guardian.validate_admin_entity
   ;;
 
-  let update =
-    CustomFieldCommand.Update.effects
-    |> custom_field_effects
-    |> Middleware.Guardian.validate_generic
-  ;;
-
-  let publish =
-    CustomFieldCommand.Publish.effects
-    |> custom_field_effects
-    |> Middleware.Guardian.validate_generic
-  ;;
-
-  let delete =
-    CustomFieldCommand.Destroy.effects
-    |> custom_field_effects
-    |> Middleware.Guardian.validate_generic
-  ;;
+  let update = custom_field_effects CustomFieldCommand.Update.effects
+  let publish = custom_field_effects CustomFieldCommand.Publish.effects
+  let delete = custom_field_effects CustomFieldCommand.Destroy.effects
 end
diff --git a/pool/web/handler/admin_custom_fields.ml b/pool/web/handler/admin_custom_fields.ml
@@ -340,7 +340,7 @@ end = struct
   module Guardian = Middleware.Guardian
 
   let custom_field_effects =
-    Guardian.id_effects Custom_field.Id.of_string Field.CustomField
+    Guardian.id_effects Custom_field.Id.validate Field.CustomField
   ;;
 
   let index =
@@ -352,23 +352,8 @@ end = struct
     CustomFieldCommand.Create.effects |> Guardian.validate_admin_entity
   ;;
 
-  let update =
-    CustomFieldCommand.Update.effects
-    |> custom_field_effects
-    |> Guardian.validate_generic
-  ;;
-
-  let delete =
-    CustomFieldCommand.Delete.effects
-    |> custom_field_effects
-    |> Guardian.validate_generic
-  ;;
-
-  let publish =
-    CustomFieldCommand.Publish.effects
-    |> custom_field_effects
-    |> Guardian.validate_generic
-  ;;
-
+  let update = custom_field_effects CustomFieldCommand.Update.effects
+  let delete = custom_field_effects CustomFieldCommand.Delete.effects
+  let publish = custom_field_effects CustomFieldCommand.Publish.effects
   let sort = CustomFieldCommand.Sort.effects |> Guardian.validate_admin_entity
 end
diff --git a/pool/web/handler/admin_experiments.ml b/pool/web/handler/admin_experiments.ml
@@ -557,7 +557,7 @@ end = struct
   module Guardian = Middleware.Guardian
 
   let experiment_effects =
-    Guardian.id_effects Experiment.Id.of_string Field.Experiment
+    Guardian.id_effects Experiment.Id.validate Field.Experiment
   ;;
 
   let index =
@@ -568,60 +568,34 @@ end = struct
     ExperimentCommand.Create.effects |> Guardian.validate_admin_entity
   ;;
 
-  let read =
-    let read id = Experiment.Guard.Access.read id in
-    read |> experiment_effects |> Guardian.validate_generic
-  ;;
-
-  let update =
-    ExperimentCommand.Update.effects
-    |> experiment_effects
-    |> Guardian.validate_generic
-  ;;
-
-  let delete =
-    ExperimentCommand.Delete.effects
-    |> experiment_effects
-    |> Guardian.validate_generic
-  ;;
+  let read = experiment_effects Experiment.Guard.Access.read
+  let update = experiment_effects ExperimentCommand.Update.effects
+  let delete = experiment_effects ExperimentCommand.Delete.effects
 
   module Filter = struct
     include Helpers.Access
 
-    let combined_effects effects req =
-      let open HttpUtils in
-      let filter_id = find_id FilterEntity.Id.of_string Field.Filter req in
-      let id = find_id Experiment.Id.of_string Field.Experiment req in
-      effects id filter_id
-    ;;
-
-    let create =
-      ExperimentCommand.CreateFilter.effects
-      |> experiment_effects
-      |> Guardian.validate_generic
-    ;;
-
-    let update =
-      ExperimentCommand.UpdateFilter.effects
-      |> combined_effects
-      |> Guardian.validate_generic
+    let combined_effects validation_set =
+      let open CCResult.Infix in
+      let find = HttpUtils.find_id in
+      Guardian.validate_generic
+      @@ fun req ->
+      let* filter_id = find FilterEntity.Id.validate Field.Filter req in
+      let* id = find Experiment.Id.validate Field.Experiment req in
+      validation_set id filter_id |> CCResult.return
     ;;
 
-    let delete =
-      ExperimentCommand.DeleteFilter.effects
-      |> combined_effects
-      |> Guardian.validate_generic
-    ;;
+    let create = experiment_effects ExperimentCommand.CreateFilter.effects
+    let update = combined_effects ExperimentCommand.UpdateFilter.effects
+    let delete = combined_effects ExperimentCommand.DeleteFilter.effects
   end
 
   let search = index
 
   let message_history =
-    (fun id ->
+    experiment_effects (fun id ->
       Pool_queue.Guard.Access.index
         ~id:(Guard.Uuid.target_of Experiment.Id.value id)
         ())
-    |> experiment_effects
-    |> Guardian.validate_generic
   ;;
 end
diff --git a/pool/web/handler/admin_experiments_assignments.ml b/pool/web/handler/admin_experiments_assignments.ml
@@ -545,34 +545,18 @@ end = struct
   module AssignmentCommand = Cqrs_command.Assignment_command
   module Guardian = Middleware.Guardian
 
-  let combined_effects fcn req =
-    let open HttpUtils in
-    let experiment_id = find_id Experiment.Id.of_string Field.Experiment req in
-    let assignment_id = find_id Assignment.Id.of_string Field.Assignment req in
-    fcn experiment_id assignment_id
+  let combined_effects validation_set =
+    let open CCResult.Infix in
+    let find = HttpUtils.find_id in
+    Guardian.validate_generic
+    @@ fun req ->
+    let* experiment_id = find Experiment.Id.validate Field.Experiment req in
+    let* assignment_id = find Assignment.Id.validate Field.Assignment req in
+    validation_set experiment_id assignment_id |> CCResult.return
   ;;
 
-  let delete =
-    Assignment.Guard.Access.delete
-    |> combined_effects
-    |> Guardian.validate_generic
-  ;;
-
-  let cancel =
-    AssignmentCommand.Cancel.effects
-    |> combined_effects
-    |> Guardian.validate_generic
-  ;;
-
-  let mark_as_deleted =
-    AssignmentCommand.MarkAsDeleted.effects
-    |> combined_effects
-    |> Guardian.validate_generic
-  ;;
-
-  let update =
-    Assignment.Guard.Access.update
-    |> combined_effects
-    |> Guardian.validate_generic
-  ;;
+  let delete = combined_effects Assignment.Guard.Access.delete
+  let cancel = combined_effects AssignmentCommand.Cancel.effects
+  let mark_as_deleted = combined_effects AssignmentCommand.MarkAsDeleted.effects
+  let update = combined_effects Assignment.Guard.Access.update
 end
diff --git a/pool/web/handler/admin_experiments_invitations.ml b/pool/web/handler/admin_experiments_invitations.ml
@@ -249,37 +249,21 @@ end = struct
   module Guardian = Middleware.Guardian
 
   let experiment_effects =
-    Guardian.id_effects Experiment.Id.of_string Field.Experiment
+    Guardian.id_effects Experiment.Id.validate Field.Experiment
   ;;
 
-  let combined_effects fcn req =
-    let open HttpUtils in
-    let experiment_id = find_id Experiment.Id.of_string Field.Experiment req in
-    let invitation_id = find_id Pool_common.Id.of_string Field.Invitation req in
-    fcn experiment_id invitation_id
+  let combined_effects validation_set =
+    let open CCResult.Infix in
+    let find = HttpUtils.find_id in
+    Guardian.validate_generic
+    @@ fun req ->
+    let* experiment_id = find Experiment.Id.validate Field.Experiment req in
+    let* invitation_id = find Pool_common.Id.validate Field.Invitation req in
+    validation_set experiment_id invitation_id |> CCResult.return
   ;;
 
-  let index =
-    Invitation.Guard.Access.index
-    |> experiment_effects
-    |> Guardian.validate_generic ~any_id:true
-  ;;
-
-  let create =
-    InvitationCommand.Create.effects
-    |> experiment_effects
-    |> Guardian.validate_generic
-  ;;
-
-  let read =
-    Invitation.Guard.Access.read
-    |> combined_effects
-    |> Guardian.validate_generic
-  ;;
-
-  let resend =
-    InvitationCommand.Resend.effects
-    |> combined_effects
-    |> Guardian.validate_generic
-  ;;
+  let index = experiment_effects Invitation.Guard.Access.index
+  let create = experiment_effects InvitationCommand.Create.effects
+  let read = combined_effects Invitation.Guard.Access.read
+  let resend = combined_effects InvitationCommand.Resend.effects
 end