From 8704a9f3913bb1a185b8bd96982e42753c31569a Mon Sep 17 00:00:00 2001 From: timohuber Date: Tue, 8 Aug 2023 15:02:57 +0200 Subject: [PATCH] Bug/1860 updating experiment removes filter (#184) * do not overwrite filter when updating experiment * fix experiment update test cases --------- Co-authored-by: Timo Huber --- pool/cqrs_command/experiment_command.ml | 36 +++---- pool/test/command.ml | 5 + pool/test/experiment_test.ml | 122 ++++++++++++++++++++---- pool/test/test_utils.ml | 6 ++ 4 files changed, 135 insertions(+), 34 deletions(-) diff --git a/pool/cqrs_command/experiment_command.ml b/pool/cqrs_command/experiment_command.ml index 0b65d3ab6..0a82d2831 100644 --- a/pool/cqrs_command/experiment_command.ml +++ b/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 ] ;; diff --git a/pool/test/command.ml b/pool/test/command.ml index 6278e7ecf..009531e22 100644 --- a/pool/test/command.ml +++ b/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 diff --git a/pool/test/experiment_test.ml b/pool/test/experiment_test.ml index cd86d43f2..765fbb5bc 100644 --- a/pool/test/experiment_test.ml +++ b/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 ;; diff --git a/pool/test/test_utils.ml b/pool/test/test_utils.ml index e09f539ba..aea5a898d 100644 --- a/pool/test/test_utils.ml +++ b/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.