Delete SMTP Server

.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",

.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

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

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

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
 ;;

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)

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|

pool/app/pool_common/entity_i18n.ml

@@ -254,6 +254,7 @@ type confirmable =
   | DeleteCustomField
   | DeleteCustomFieldOption
   | DeleteEmailSuffix
+  | DeleteSmtpServer
   | DeleteExperiment
   | DeleteExperimentFilter
   | DeleteFile

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"

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"

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

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 ]

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"

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 ] )

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 ()
+;;

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 =