diff --git a/.devcontainer/devcontainer.json b/.devcontainer/devcontainer.json index 845b247f8..9bf90cab0 100644 --- a/.devcontainer/devcontainer.json +++ b/.devcontainer/devcontainer.json @@ -3,7 +3,10 @@ // devcontainer docu https://code.visualstudio.com/docs/remote/containers#_devcontainerjson-reference { "name": "Pool Tool", - "dockerComposeFile": ["./docker-compose.yml", "./docker-compose.override.yml"], + "dockerComposeFile": [ + "./docker-compose.yml", + "./docker-compose.override.yml" + ], "service": "dev", "runServices": [ "dev", diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 2ce1545a1..0c64fb674 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -50,7 +50,7 @@ jobs: SMTP_SENDER: test@econ.uzh.ch TEST_EMAIL: test@econ.uzh.ch with: - image: ocaml/opam:debian-10-ocaml-4.14 + image: ocaml/opam:debian-12-ocaml-4.14 options: -v ${{ github.workspace }}:/app -w /app -e DATABASE_URL -e DATABASE_URL_TENANT_ONE -e TEST_EMAIL -e SMTP_SENDER -e SIHL_ENV -e EMAIL_RATE_LIMIT -e MATCHER_MAX_CAPACITY run: | # Reclaim required directory permissions diff --git a/pool/app/email/email.mli b/pool/app/email/email.mli index 177d8ae18..57c1cfe71 100644 --- a/pool/app/email/email.mli +++ b/pool/app/email/email.mli @@ -151,6 +151,8 @@ module SmtpAuth : sig ; default : Default.t } + type smtp = t + type update_password = { id : Id.t ; password : Password.t option @@ -172,6 +174,8 @@ module SmtpAuth : sig ; default : Default.t } + val to_entity : t -> smtp + val create : ?id:Id.t -> Label.t @@ -290,6 +294,7 @@ type event = | BulkSent of (Sihl_email.t * SmtpAuth.Id.t option) list | SmtpCreated of SmtpAuth.Write.t | SmtpEdited of SmtpAuth.t + | SmtpDeleted of SmtpAuth.Id.t | SmtpPasswordEdited of SmtpAuth.update_password val handle_event : Pool_database.Label.t -> event -> unit Lwt.t diff --git a/pool/app/email/entity_smtp.ml b/pool/app/email/entity_smtp.ml index 4b0cc5d4e..abc8c0e5f 100644 --- a/pool/app/email/entity_smtp.ml +++ b/pool/app/email/entity_smtp.ml @@ -93,6 +93,8 @@ type t = } [@@deriving eq, show, sexp_of] +type smtp = t + type update_password = { id : Id.t ; password : Password.t option [@opaque] @@ -126,4 +128,16 @@ module Write = struct ; default } ;; + + let to_entity (t : t) : smtp = + { id = t.id + ; label = t.label + ; server = t.server + ; port = t.port + ; username = t.username + ; mechanism = t.mechanism + ; protocol = t.protocol + ; default = t.default + } + ;; end diff --git a/pool/app/email/event.ml b/pool/app/email/event.ml index eb50aa71e..3b7c3b7de 100644 --- a/pool/app/email/event.ml +++ b/pool/app/email/event.ml @@ -61,6 +61,7 @@ type event = | BulkSent of (Sihl_email.t * SmtpAuth.Id.t option) list | SmtpCreated of SmtpAuth.Write.t | SmtpEdited of SmtpAuth.t + | SmtpDeleted of SmtpAuth.Id.t | SmtpPasswordEdited of SmtpAuth.update_password [@@deriving eq, show, variants] @@ -84,4 +85,7 @@ let handle_event pool : event -> unit Lwt.t = function | SmtpPasswordEdited updated_password -> let%lwt () = Repo.Smtp.update_password pool updated_password in Lwt.return_unit + | SmtpDeleted id -> + let%lwt () = Repo.Smtp.delete pool id in + Lwt.return_unit ;; diff --git a/pool/app/email/repo/repo.ml b/pool/app/email/repo/repo.ml index 80ff11291..4f9066fe3 100644 --- a/pool/app/email/repo/repo.ml +++ b/pool/app/email/repo/repo.ml @@ -25,6 +25,7 @@ module Smtp = struct let find_all = Sql.Smtp.find_all let insert = Sql.Smtp.insert let update = Sql.Smtp.update + let delete = Sql.Smtp.delete let update_password label Entity.SmtpAuth.{ id; password } = Sql.Smtp.update_password label (id, password) diff --git a/pool/app/email/repo/repo_sql.ml b/pool/app/email/repo/repo_sql.ml index 30a283601..5d4870014 100644 --- a/pool/app/email/repo/repo_sql.ml +++ b/pool/app/email/repo/repo_sql.ml @@ -381,6 +381,19 @@ module Smtp = struct Utils.Database.exec (Database.Label.value pool) update_request t ;; + let delete_request = + let open Caqti_request.Infix in + {sql| + DELETE FROM pool_smtp + WHERE uuid = UNHEX(REPLACE(?, '-', '')) + |sql} + |> RepoEntity.SmtpAuth.(Id.t ->. Caqti_type.unit) + ;; + + let delete pool t = + Utils.Database.exec (Database.Label.value pool) delete_request t + ;; + let update_password_request = let open Caqti_request.Infix in {sql| diff --git a/pool/app/pool_common/entity_i18n.ml b/pool/app/pool_common/entity_i18n.ml index 0fb852261..e7edfaa73 100644 --- a/pool/app/pool_common/entity_i18n.ml +++ b/pool/app/pool_common/entity_i18n.ml @@ -254,6 +254,7 @@ type confirmable = | DeleteCustomField | DeleteCustomFieldOption | DeleteEmailSuffix + | DeleteSmtpServer | DeleteExperiment | DeleteExperimentFilter | DeleteFile diff --git a/pool/app/pool_common/locales/i18n_de.ml b/pool/app/pool_common/locales/i18n_de.ml index f529f3b43..5cefee67e 100644 --- a/pool/app/pool_common/locales/i18n_de.ml +++ b/pool/app/pool_common/locales/i18n_de.ml @@ -574,6 +574,7 @@ let confirmable_to_string confirmable = | DeleteMailing -> "den Versand", "löschen", None | DeleteMessageTemplate -> "das Nachrichtentemplate", "löschen", None | DeleteSession -> "die Session", "löschen", None + | DeleteSmtpServer -> "E-Mail Server", "löschen", None | MarkAssignmentAsDeleted -> "die Anmeldung", "als gelöscht markieren", None | MarkAssignmentWithFollowUpsAsDeleted -> ( "die Anmeldung" diff --git a/pool/app/pool_common/locales/i18n_en.ml b/pool/app/pool_common/locales/i18n_en.ml index add77ab72..5fa0c0d22 100644 --- a/pool/app/pool_common/locales/i18n_en.ml +++ b/pool/app/pool_common/locales/i18n_en.ml @@ -552,6 +552,7 @@ let confirmable_to_string confirmable = | DeleteMailing -> "mailing", "delete", None | DeleteMessageTemplate -> "message template", "delete", None | DeleteSession -> "session", "delete", None + | DeleteSmtpServer -> "email Server", "delete", None | PublisCustomField -> ( "field an all associated options" , "publish" diff --git a/pool/cqrs_command/smtp_command.ml b/pool/cqrs_command/smtp_command.ml index 0730662e0..c67a26ad0 100644 --- a/pool/cqrs_command/smtp_command.ml +++ b/pool/cqrs_command/smtp_command.ml @@ -130,6 +130,7 @@ module Update : sig val handle : ?tags:Logs.Tag.set + -> ?clear_id:System_event.Id.t -> SmtpAuth.t option -> SmtpAuth.t -> t @@ -145,6 +146,7 @@ end = struct let handle ?(tags = Logs.Tag.empty) + ?(clear_id = System_event.Id.create ()) (default_smtp : SmtpAuth.t option) (smtp_auth : SmtpAuth.t) (command : t) @@ -171,7 +173,10 @@ end = struct ; default } in - Ok [ Email.SmtpEdited update |> Pool_event.email; clear_cache_event () ] + Ok + [ Email.SmtpEdited update |> Pool_event.email + ; clear_cache_event ~id:clear_id () + ] ;; let decode data = @@ -220,3 +225,31 @@ end = struct let effects = Email.Guard.Access.Smtp.update end + +module Delete : sig + include Common.CommandSig with type t = SmtpAuth.Id.t + + val handle + : ?tags:Logs.Tag.set + -> ?clear_id:System_event.Id.t + -> t + -> (Pool_event.t list, Pool_common.Message.error) result + + val effects : SmtpAuth.Id.t -> Guard.ValidationSet.t +end = struct + type t = SmtpAuth.Id.t + + let handle + ?(tags = Logs.Tag.empty) + ?(clear_id = System_event.Id.create ()) + (command : t) + = + Logs.info ~src (fun m -> m "Handle command Delete" ~tags); + Ok + [ Email.SmtpDeleted command |> Pool_event.email + ; clear_cache_event ~id:clear_id () + ] + ;; + + let effects = Email.Guard.Access.Smtp.update +end diff --git a/pool/routes/routes.ml b/pool/routes/routes.ml index 1f358e0c7..4dcd81bb5 100644 --- a/pool/routes/routes.ml +++ b/pool/routes/routes.ml @@ -709,6 +709,7 @@ module Admin = struct let specific = [ get "" ~middlewares:[ Access.update ] show ; post "" ~middlewares:[ Access.update ] update + ; post "/delete" ~middlewares:[ Access.delete ] delete ; post "/password" ~middlewares:[ Access.update ] update_password ] in @@ -844,6 +845,7 @@ module Root = struct [ get "" ~middlewares:[ Access.index ] show_smtp ; post "/create" ~middlewares:[ Access.create ] create_smtp ; post "/:smtp" ~middlewares:[ Access.update ] update_smtp + ; post "/:smtp/delete" ~middlewares:[ Access.delete ] delete_smtp ; post "/:smtp/password" ~middlewares:[ Access.update ] diff --git a/pool/test/command.ml b/pool/test/command.ml index 0d0bd2605..ba862de4a 100644 --- a/pool/test/command.ml +++ b/pool/test/command.ml @@ -87,6 +87,14 @@ let () = "create tenant smtp auth and force default" `Quick Tenant_test.create_smtp_force_defaut + ; test_case + "update tenant smtp auth" + `Quick + Tenant_test.update_smtp_auth + ; test_case + "delete tenant smtp auth" + `Quick + Tenant_test.delete_smtp_auth ; test_case "create tenant" `Quick Tenant_test.create_tenant ; test_case "update tenant details" diff --git a/pool/test/integration.ml b/pool/test/integration.ml index 690781464..b503e707a 100644 --- a/pool/test/integration.ml +++ b/pool/test/integration.ml @@ -30,6 +30,8 @@ let suite = `Slow update_terms_and_conditions ; test_case "login after terms update" `Slow login_after_terms_update + ; test_case "can create smtp auth" `Slow create_smtp_auth + ; test_case "can delete smtp auth" `Slow delete_smtp_auth ] ) ; ( "dev/test" , [ test_case "intercept email" `Slow Common_test.validate_email ] ) diff --git a/pool/test/tenant_settings_test.ml b/pool/test/tenant_settings_test.ml index a08651190..3001c1e95 100644 --- a/pool/test/tenant_settings_test.ml +++ b/pool/test/tenant_settings_test.ml @@ -297,3 +297,97 @@ let login_after_terms_update _ () = expected accepted) ;; + +(* Test the creation of an SMTP Authentication record. *) +let create_smtp_auth = + Test_utils.case + @@ fun () -> + let ( let* ) x f = Lwt_result.bind (Lwt_result.lift x) f in + let ( let& ) = Lwt_result.bind in + let test_db = Test_utils.Data.database_label in + let open Email.SmtpAuth in + (* create an smtp auth instance *) + let id = Id.create () in + let* label = Label.create ("a-label-" ^ Id.show id) in + let* server = Server.create "a-server" in + let* port = Port.create 2112 in + let* username = Username.create "a-username" in + let* password = Password.create "Password1!" in + let mechanism = Mechanism.PLAIN in + let protocol = Protocol.SSL_TLS in + let default = Default.create false in + let* write_event = + Email.SmtpAuth.Write.create + ~id + label + server + port + (Some username) + (Some password) + mechanism + protocol + default + in + (* feed the event into the event handler to affect the database *) + let& () = + [ Email.SmtpCreated write_event |> Pool_event.email ] + |> Pool_event.handle_events test_db + |> Lwt_result.ok + in + (* get the smtp auth that was actually saved and compare it *) + let expected = Email.SmtpAuth.Write.to_entity write_event in + let& actual = Email.SmtpAuth.find test_db id in + Alcotest.(check Test_utils.smtp_auth "smtp saved correctly" expected actual); + Lwt.return_ok () +;; + +(* Test the deletion of an SMTP Authentication record. *) +let delete_smtp_auth = + Test_utils.case + @@ fun () -> + let ( let* ) x f = Lwt_result.bind (Lwt_result.lift x) f in + let ( let& ) = Lwt_result.bind in + let ( let^ ) = Lwt.bind in + let test_db = Test_utils.Data.database_label in + let open Email.SmtpAuth in + (* create an smtp auth instance *) + let id = Id.create () in + let* label = Label.create ("a-label-" ^ Id.show id) in + let* server = Server.create "a-server" in + let* port = Port.create 2112 in + let* username = Username.create "a-username" in + let* password = Password.create "Password1!" in + let mechanism = Mechanism.PLAIN in + let protocol = Protocol.SSL_TLS in + let default = Default.create false in + let* write_event = + Email.SmtpAuth.Write.create + ~id + label + server + port + (Some username) + (Some password) + mechanism + protocol + default + in + (* feed the event into the event handler to affect the database *) + let& () = + [ Email.SmtpCreated write_event |> Pool_event.email + ; Email.SmtpDeleted id |> Pool_event.email + ] + |> Pool_event.handle_events test_db + |> Lwt_result.ok + in + (* get the smtp auth that was actually saved and compare it *) + let^ result = Email.SmtpAuth.find test_db id in + let error = Result.get_error result in + Alcotest.( + check + Test_utils.error + "the auth record was not deleted" + error + (Pool_common.Message.NotFound Field.Smtp)); + Lwt.return_ok () +;; diff --git a/pool/test/tenant_test.ml b/pool/test/tenant_test.ml index 9d45ce24b..d6f9daee0 100644 --- a/pool/test/tenant_test.ml +++ b/pool/test/tenant_test.ml @@ -281,16 +281,17 @@ let create_smtp_force_defaut () = let update_smtp_auth () = let open Email in + let id = System_event.Id.create () in let smtp_auth = Data.Smtp.(create () |> from_write) in let events = let open CCResult in let open Cqrs_command.Smtp_command.Update in - decode (Data.Smtp.urlencoded ()) >>= handle None smtp_auth + decode (Data.Smtp.urlencoded ()) >>= handle ~clear_id:id None smtp_auth in let expected = let sys_event = let open System_event in - Job.SmtpAccountUpdated |> create |> created |> Pool_event.system_event + Job.SmtpAccountUpdated |> create ~id |> created |> Pool_event.system_event in Ok [ SmtpEdited smtp_auth |> Pool_event.email; sys_event ] in @@ -302,6 +303,27 @@ let update_smtp_auth () = events) ;; +let delete_smtp_auth () = + let open Email in + let id = System_event.Id.create () in + let smtp_auth = Data.Smtp.(create () |> from_write) in + let smtp_id = SmtpAuth.(smtp_auth.id) in + let events = Cqrs_command.Smtp_command.Delete.handle ~clear_id:id smtp_id in + let expected = + let sys_event = + let open System_event in + Job.SmtpAccountUpdated |> create ~id |> created |> Pool_event.system_event + in + Ok [ SmtpDeleted smtp_id |> Pool_event.email; sys_event ] + in + Alcotest.( + check + (result (list Test_utils.event) Test_utils.error) + "succeeds" + expected + events) +;; + let[@warning "-4"] create_tenant () = let open Data in let root_events = diff --git a/pool/test/test_utils.ml b/pool/test/test_utils.ml index ec2c3197b..68dce1fed 100644 --- a/pool/test/test_utils.ml +++ b/pool/test/test_utils.ml @@ -30,6 +30,7 @@ let error = ;; let contact = Alcotest.testable Contact.pp Contact.equal +let smtp_auth = Alcotest.testable Email.SmtpAuth.pp Email.SmtpAuth.equal let check_result ?(msg = "succeeds") = let open Alcotest in @@ -546,3 +547,11 @@ module Repo = struct Pool_location.find_all Data.database_label ||> CCList.hd ;; end + +(* NOTE(@leostera): here be dragons. This machinery gets rid of any resulting + value we have. It will fail a test if the underlying promise returns an + Error. *) +let case fn (_switch : Lwt_switch.t) () : unit Lwt.t = + let result = Lwt_result.get_exn @@ Lwt_result.catch fn in + Lwt.map (fun _ -> ()) result +;; diff --git a/pool/web/handler/admin_settings_smtp.ml b/pool/web/handler/admin_settings_smtp.ml index a1a6f06b6..25c5384b4 100644 --- a/pool/web/handler/admin_settings_smtp.ml +++ b/pool/web/handler/admin_settings_smtp.ml @@ -175,6 +175,26 @@ let new_form req = result |> HttpUtils.extract_happy_path ~src req ;; +let delete_base location req = + let tags = Pool_context.Logger.Tags.req req in + let path = active_navigation location in + HttpUtils.extract_happy_path ~src req + @@ fun Pool_context.{ database_label; _ } -> + let smtp_id = + Sihl.Web.Router.param req (Field.show Field.Smtp) |> SmtpAuth.Id.of_string + in + Cqrs_command.Smtp_command.Delete.handle ~tags smtp_id + |> Lwt_result.lift + |>> (fun events -> + let%lwt () = Pool_event.handle_events ~tags database_label events in + Http_utils.redirect_to_with_actions + path + [ Message.set ~success:[ Pool_common.Message.(Deleted Field.Smtp) ] ]) + |> Utils.Lwt_result.map_error (fun err -> err, path) +;; + +let delete = delete_base `Tenant + module Access : module type of Helpers.Access = struct include Helpers.Access module Guardian = Middleware.Guardian @@ -190,4 +210,8 @@ module Access : module type of Helpers.Access = struct let update = Command.Update.effects |> smtp_effects |> Guardian.validate_generic ;; + + let delete = + Email.Guard.Access.Smtp.delete |> smtp_effects |> Guardian.validate_generic + ;; end diff --git a/pool/web/handler/root_settings.ml b/pool/web/handler/root_settings.ml index 41ee140cf..02425ed72 100644 --- a/pool/web/handler/root_settings.ml +++ b/pool/web/handler/root_settings.ml @@ -17,4 +17,6 @@ let update_smtp_password = Pool_common.Message.SmtpPasswordUpdated ;; +let delete_smtp = Admin_settings_smtp.delete_base `Root + module Access = Admin_settings.Smtp.Access diff --git a/pool/web/view/component/component_input.ml b/pool/web/view/component/component_input.ml index 3b9843f7d..b4837c3b6 100644 --- a/pool/web/view/component/component_input.ml +++ b/pool/web/view/component/component_input.ml @@ -10,6 +10,20 @@ let submit_type_to_class = function | `Success -> "success" ;; +let button_group buttons = + div + ~a: + [ a_class + [ "flexrow" + ; "justify-end" + ; "align-center" + ; "items-center" + ; "flex-gap-xs" + ] + ] + buttons +;; + let language_select options selected diff --git a/pool/web/view/page/page_admin_settings_smtp.ml b/pool/web/view/page/page_admin_settings_smtp.ml index c57a17d4a..37765c816 100644 --- a/pool/web/view/page/page_admin_settings_smtp.ml +++ b/pool/web/view/page/page_admin_settings_smtp.ml @@ -30,6 +30,22 @@ let index Pool_context.{ language; _ } location smtp_auth_list = |> Component.Table.fields_to_txt language) @ [ add_btn ] in + let delete_button (auth : SmtpAuth.t) = + let open SmtpAuth in + let action_path = + Format.asprintf "%s/%s/delete" (base_path location) (auth.id |> Id.value) + in + form + ~a: + [ a_method `Post + ; a_action action_path + ; a_user_data + "confirmable" + Pool_common.( + Utils.confirmable_to_string language I18n.DeleteSmtpServer) + ] + [ submit_icon ~classnames:[ "error" ] Icon.TrashOutline ] + in let rows = let open SmtpAuth in smtp_auth_list @@ -40,8 +56,14 @@ let index Pool_context.{ language; _ } location smtp_auth_list = ; auth.mechanism |> Mechanism.show |> txt ; auth.protocol |> Protocol.show |> txt ; auth.default |> Default.value |> Utils.Bool.to_string |> txt - ; edit_link - (Format.asprintf "%s/%s" (base_path location) (auth.id |> Id.value)) + ; button_group + [ edit_link + (Format.asprintf + "%s/%s" + (base_path location) + (auth.id |> Id.value)) + ; delete_button auth + ] ]) in div