Bug/1860 updating experiment removes filter (#184)

* do not overwrite filter when updating experiment

* fix experiment update test cases

---------

Co-authored-by: Timo Huber <[email protected]>

pool/cqrs_command/experiment_command.ml

@@ -133,27 +133,29 @@ end = struct
     experiment
     contact_person
     organisational_unit
-    smtp_auth
+    smtp
     (command : t)
     =
     Logs.info ~src (fun m -> m "Handle command Update" ~tags);
     let open CCResult in
-    let* experiment =
-      Experiment.create
-        ~id:experiment.Experiment.id
-        command.title
-        command.public_title
-        command.description
-        command.cost_center
-        organisational_unit
-        (contact_person |> CCOption.map Admin.id)
-        (smtp_auth |> CCOption.map Email.SmtpAuth.(fun ({ id; _ } : t) -> id))
-        command.direct_registration_disabled
-        command.registration_disabled
-        command.allow_uninvited_signup
-        command.external_data_required
-        command.experiment_type
-        command.session_reminder_lead_time
+    let experiment =
+      Experiment.
+        { experiment with
+          title = command.title
+        ; public_title = command.public_title
+        ; description = command.description
+        ; cost_center = command.cost_center
+        ; organisational_unit
+        ; contact_person_id = CCOption.map Admin.id contact_person
+        ; smtp_auth_id =
+            CCOption.map Email.SmtpAuth.(fun ({ id; _ } : t) -> id) smtp
+        ; direct_registration_disabled = command.direct_registration_disabled
+        ; registration_disabled = command.registration_disabled
+        ; allow_uninvited_signup = command.allow_uninvited_signup
+        ; external_data_required = command.external_data_required
+        ; experiment_type = command.experiment_type
+        ; session_reminder_lead_time = command.session_reminder_lead_time
+        }
     in
     Ok [ Experiment.Updated experiment |> Pool_event.experiment ]
   ;;

pool/test/command.ml

@@ -199,6 +199,11 @@ let () =
             `Quick
             Experiment_test.create_without_title
         ; test_case "upate experiment" `Quick Experiment_test.update
+        ; test_case
+            "add ou and contact person"
+            `Quick
+            Experiment_test.update_add_ou_and_contact_person
+        ; test_case "remove ou" `Quick Experiment_test.update_remove_ou
         ; test_case
             "delete experiment with sessions"
             `Quick

pool/test/experiment_test.ml

@@ -9,11 +9,45 @@ let experiment_boolean_fields =
   Experiment.boolean_fields |> CCList.map Pool_common.Message.Field.show
 ;;
 
+let boolean_fields =
+  Experiment.boolean_fields |> CCList.map Pool_common.Message.Field.show
+;;
+
 module Data = struct
-  let contact_person = Test_utils.Model.create_admin ()
+  let organisational_unit = Test_utils.Model.create_organisational_unit ()
+
+  let contact_person =
+    let open Pool_context in
+    Test_utils.Model.create_admin ()
+    |> function
+    | Admin admin -> admin
+    | Contact _ | Guest -> failwith "Invalid admin"
+  ;;
+
   let title = "New experiment"
   let public_title = "public_experiment_title"
   let description = "Description"
+  let cost_center = "cost_center"
+  let direct_registration_disabled = "false"
+  let registration_disabled = "false"
+  let allow_uninvited_signup = "false"
+  let external_data_required = "false"
+  let experiment_type = Pool_common.ExperimentType.(show Lab)
+
+  let urlencoded =
+    Pool_common.Message.
+      [ Field.(show Title), [ title ]
+      ; Field.(show PublicTitle), [ public_title ]
+      ; Field.(show Description), [ description ]
+      ; Field.(show CostCenter), [ cost_center ]
+      ; ( Field.(show DirectRegistrationDisabled)
+        , [ direct_registration_disabled ] )
+      ; Field.(show RegistrationDisabled), [ registration_disabled ]
+      ; Field.(show AllowUninvitedSignup), [ allow_uninvited_signup ]
+      ; Field.(show ExternalDataRequired), [ external_data_required ]
+      ; Field.(show ExperimentType), [ experiment_type ]
+      ]
+  ;;
 
   module Filter = struct
     open Filter
@@ -62,17 +96,29 @@ module Data = struct
       ; title
       ; public_title
       ; description = Some description
-      ; cost_center = Some ("F-00000-11-22" |> CostCenter.of_string)
+      ; cost_center = Some (cost_center |> CostCenter.of_string)
       ; organisational_unit = None
       ; filter
       ; contact_person_id = None
       ; smtp_auth_id = None
       ; direct_registration_disabled =
-          false |> DirectRegistrationDisabled.create
-      ; registration_disabled = false |> RegistrationDisabled.create
-      ; allow_uninvited_signup = false |> AllowUninvitedSignup.create
-      ; external_data_required = false |> ExternalDataRequired.create
-      ; experiment_type = Some Pool_common.ExperimentType.Lab
+          direct_registration_disabled
+          |> Utils.Bool.of_string
+          |> DirectRegistrationDisabled.create
+      ; registration_disabled =
+          registration_disabled
+          |> Utils.Bool.of_string
+          |> RegistrationDisabled.create
+      ; allow_uninvited_signup =
+          allow_uninvited_signup
+          |> Utils.Bool.of_string
+          |> AllowUninvitedSignup.create
+      ; external_data_required =
+          external_data_required
+          |> Utils.Bool.of_string
+          |> ExternalDataRequired.create
+      ; experiment_type =
+          Some (experiment_type |> Pool_common.ExperimentType.read)
       ; session_reminder_lead_time = None
       ; created_at = Common.CreatedAt.create ()
       ; updated_at = Common.UpdatedAt.create ()
@@ -87,8 +133,8 @@ let handle_create ?organisational_unit ?contact_person ?smtp_auth =
 let handle_update ?organisational_unit ?contact_person ?smtp_auth experiment =
   ExperimentCommand.Update.handle
     experiment
-    organisational_unit
     contact_person
+    organisational_unit
     smtp_auth
 ;;
 
@@ -118,24 +164,66 @@ let create_without_title () =
 ;;
 
 let update () =
-  let experiment = Model.create_experiment () in
+  let experiment = Data.experiment |> Test_utils.get_or_failwith_pool_error in
   let open CCResult.Infix in
   let events =
-    Pool_common.Message.Field.
-      [ Title |> show, [ Data.title ]
-      ; Description |> show, [ Data.description ]
-      ]
+    Data.urlencoded
+    |> Http_utils.format_request_boolean_values boolean_fields
     |> ExperimentCommand.Update.decode
     >>= handle_update experiment
   in
   let expected =
-    Pool_common.Message.Field.
-      [ Title |> show, [ Data.title ]
-      ; Description |> show, [ Data.description ]
-      ]
+    Ok [ Experiment.Updated experiment |> Pool_event.experiment ]
+  in
+  Test_utils.check_result expected events
+;;
+
+let update_add_ou_and_contact_person () =
+  let experiment = Data.experiment |> Test_utils.get_or_failwith_pool_error in
+  let open CCResult.Infix in
+  let events =
+    Data.urlencoded
+    |> Http_utils.format_request_boolean_values boolean_fields
+    |> ExperimentCommand.Update.decode
+    >>= handle_update
+          ~organisational_unit:Data.organisational_unit
+          ~contact_person:Data.contact_person
+          experiment
+  in
+  let expected =
+    Ok
+      Experiment.
+        [ Updated
+            { experiment with
+              organisational_unit = Some Data.organisational_unit
+            ; contact_person_id = Some (Admin.id Data.contact_person)
+            }
+          |> Pool_event.experiment
+        ]
+  in
+  Test_utils.check_result expected events
+;;
+
+let update_remove_ou () =
+  let experiment = Data.experiment |> Test_utils.get_or_failwith_pool_error in
+  let experiment =
+    Experiment.
+      { experiment with organisational_unit = Some Data.organisational_unit }
+  in
+  let open CCResult.Infix in
+  let events =
+    Data.urlencoded
+    |> Http_utils.format_request_boolean_values boolean_fields
     |> ExperimentCommand.Update.decode
     >>= handle_update experiment
   in
+  let expected =
+    Ok
+      Experiment.
+        [ Updated { experiment with organisational_unit = None }
+          |> Pool_event.experiment
+        ]
+  in
   Test_utils.check_result expected events
 ;;
 

pool/test/test_utils.ml

@@ -229,6 +229,12 @@ module Model = struct
       }
   ;;
 
+  let create_organisational_unit () =
+    let open Organisational_unit in
+    let name = Name.create "SNS" |> get_or_failwith_pool_error in
+    create name
+  ;;
+
   let experiment_to_public_experiment (experiment : Experiment.t) =
     Experiment.(
       Public.