diff --git a/.devcontainer/docker-compose.override.yml b/.devcontainer/docker-compose.override.yml index f8330db06..e69de29bb 100644 --- a/.devcontainer/docker-compose.override.yml +++ b/.devcontainer/docker-compose.override.yml @@ -1 +0,0 @@ -version: "3.8" diff --git a/.devcontainer/docker-compose.yml b/.devcontainer/docker-compose.yml index 947c991c7..6c627d867 100644 --- a/.devcontainer/docker-compose.yml +++ b/.devcontainer/docker-compose.yml @@ -1,5 +1,3 @@ -version: "3.8" - services: dev: build: @@ -16,7 +14,7 @@ services: - db-tenant:/databases/db-tenant/:ro environment: - DATABASE_URL=mariadb://root@database-root:3306/development - - DATABASE_URL_TENANT_ONE=mariadb://root@database-tenant:3306/test_econ + - DATABASE_URL_TENANT_ONE=mariadb://root@database-tenant:3306/dev_econ - DATABASE_SKIP_DEFAULT_POOL_CREATION=true - DATABASE_CHOOSE_POOL=root - OPAMSOLVERTIMEOUT=180 diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index d94c6b309..ba56bb8bb 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -81,8 +81,6 @@ jobs: permissions: packages: read env: - EMAIL_RATE_LIMIT: 3600 - MATCHER_MAX_CAPACITY: 80 MYSQL_DATABASE: test_econ MYSQL_ROOT_PASSWORD: password services: diff --git a/pool.opam.locked b/pool.opam.locked index 58447be2e..24f13001a 100644 --- a/pool.opam.locked +++ b/pool.opam.locked @@ -82,10 +82,10 @@ depends: [ "http" {= "6.2.1"} "httpaf" {= "0.7.1"} "httpaf-lwt-unix" {= "0.7.1"} - "hxd" {= "0.3.6"} + "hxd" {= "0.4.0"} "integers" {= "0.7.0"} - "ipaddr" {= "5.6.1"} - "ipaddr-sexp" {= "5.6.1"} + "ipaddr" {= "5.6.2"} + "ipaddr-sexp" {= "5.6.2"} "jane-street-headers" {= "v0.17.0" & with-test} "jst-config" {= "v0.17.0" & with-test} "jwto" {= "0.4.0"} @@ -98,7 +98,7 @@ depends: [ "lwt-dllist" {= "1.1.0"} "lwt_ppx" {= "5.9.1"} "lwt_ssl" {= "1.2.0"} - "macaddr" {= "5.6.1"} + "macaddr" {= "5.6.2"} "magic-mime" {= "1.3.1"} "mariadb" {= "1.3.0"} "markup" {= "1.0.3"} @@ -183,8 +183,8 @@ depends: [ "stdune" {= "3.21.1"} "stringext" {= "1.6.0"} "time_now" {= "v0.17.0" & with-test} - "tls" {= "2.0.3"} - "tls-lwt" {= "2.0.3"} + "tls" {= "2.0.4"} + "tls-lwt" {= "2.0.4"} "top-closure" {= "3.21.1"} "topkg" {= "1.1.1"} "tsort" {= "2.2.0"} diff --git a/pool/app/contact/dune b/pool/app/contact/dune index aa6f31935..a02c5ad06 100644 --- a/pool/app/contact/dune +++ b/pool/app/contact/dune @@ -2,6 +2,7 @@ (name contact) (libraries changelog + email i18n guard pool_common diff --git a/pool/app/contact/repo/repo.ml b/pool/app/contact/repo/repo.ml index 3c7f317c9..5e8aabf58 100644 --- a/pool/app/contact/repo/repo.ml +++ b/pool/app/contact/repo/repo.ml @@ -650,3 +650,5 @@ module InactivityNotification = struct Database.exec pool request (Entity.id contact) ;; end + +let increment_smtp_bounce = Email.Contact.increment_smtp_bounce diff --git a/pool/app/email/email.ml b/pool/app/email/email.ml index 6bed0e674..0743929e8 100644 --- a/pool/app/email/email.ml +++ b/pool/app/email/email.ml @@ -33,3 +33,8 @@ let find_active_token pool address = module Service = Email_service module Guard = Entity_guard + +module Contact = struct + let increment_smtp_bounce = Repo_sql.Contact.increment_smtp_bounce + let reset_smtp_bounce = Repo_sql.Contact.reset_smtp_bounce +end diff --git a/pool/app/email/email.mli b/pool/app/email/email.mli index ae813b872..7baffe8c5 100644 --- a/pool/app/email/email.mli +++ b/pool/app/email/email.mli @@ -123,6 +123,27 @@ module SmtpAuth : sig include Pool_model.Base.BooleanSig end + module SystemAccount : sig + include Pool_model.Base.BooleanSig + end + + module InternalRegex : sig + include Pool_model.Base.StringSig + end + + module RateLimit : sig + include Pool_model.Base.IntegerSig + + val default : t + val timediff_seconds : int + end + + module InvitationCapacity : sig + include Pool_model.Base.IntegerSig + + val default : t + end + type t = { id : Id.t ; label : Label.t @@ -132,10 +153,24 @@ module SmtpAuth : sig ; mechanism : Mechanism.t ; protocol : Protocol.t ; default : Default.t + ; system_account : SystemAccount.t + ; internal_regex : InternalRegex.t option + ; rate_limit : RateLimit.t + ; invitation_capacity : InvitationCapacity.t } val id : t -> Id.t val label : t -> Label.t + val server : t -> Server.t + val port : t -> Port.t + val username : t -> Username.t option + val mechanism : t -> Mechanism.t + val protocol : t -> Protocol.t + val default : t -> Default.t + val system_account : t -> SystemAccount.t + val internal_regex : t -> InternalRegex.t option + val rate_limit : t -> RateLimit.t + val invitation_capacity : t -> InvitationCapacity.t type smtp = t @@ -158,12 +193,20 @@ module SmtpAuth : sig ; mechanism : Mechanism.t ; protocol : Protocol.t ; default : Default.t + ; system_account : SystemAccount.t + ; internal_regex : InternalRegex.t option + ; rate_limit : RateLimit.t + ; invitation_capacity : InvitationCapacity.t } val to_entity : t -> smtp val create : ?id:Id.t + -> ?rate_limit:RateLimit.t + -> ?invitation_capacity:InvitationCapacity.t + -> ?system_account:SystemAccount.t + -> ?internal_regex:InternalRegex.t -> Label.t -> Server.t -> Port.t @@ -181,14 +224,17 @@ module SmtpAuth : sig val find_default : Database.Label.t -> (t, Pool_message.Error.t) Lwt_result.t val find_default_opt : Database.Label.t -> t option Lwt.t val find_all : Database.Label.t -> t list Lwt.t + val find_for_experiment : Database.Label.t -> t list Lwt.t val find_by : Query.t -> Database.Label.t -> (t list * Query.t) Lwt.t val defalut_is_set : Database.Label.t -> bool Lwt.t + val count_invitations_sent_since : Database.Label.t -> Id.t option -> int -> int Lwt.t val column_label : Query.Column.t val column_smtp_server : Query.Column.t val column_smtp_username : Query.Column.t val column_smtp_mechanism : Query.Column.t val column_smtp_protocol : Query.Column.t val column_smtp_default_account : Query.Column.t + val column_smtp_system_account : Query.Column.t val filterable_by : Query.Filter.human option val default_query : Query.t val searchable_by : Query.Column.t list @@ -247,7 +293,7 @@ module Service : sig : ?id:Pool_queue.Id.t -> ?new_email_address:Pool_user.EmailAddress.t -> ?new_smtp_auth_id:Pool_common.Id.t - -> ?message_template:string + -> ?message_template:Pool_common.MessageTemplateLabel.t -> ?job_ctx:Pool_queue.job_ctx -> Database.Label.t -> Job.t @@ -255,7 +301,11 @@ module Service : sig val dispatch_all : Database.Label.t - -> (Pool_queue.Id.t * Job.t * string option * Pool_queue.job_ctx option) list + -> (Pool_queue.Id.t + * Job.t + * Pool_common.MessageTemplateLabel.t option + * Pool_queue.job_ctx option) + list -> unit Lwt.t val lifecycle : Sihl.Container.lifecycle @@ -280,6 +330,11 @@ module Guard : sig end end +module Contact : sig + val increment_smtp_bounce : Database.Label.t -> Pool_user.EmailAddress.t -> unit Lwt.t + val reset_smtp_bounce : Database.Label.t -> Pool_user.EmailAddress.t -> unit Lwt.t +end + type verification_event = | Created of Pool_user.EmailAddress.t * Pool_token.t * Pool_user.Id.t | EmailVerified of unverified t @@ -291,7 +346,7 @@ val pp_verification_event : Format.formatter -> verification_event -> unit type dispatch = { job : Service.Job.t ; id : Pool_queue.Id.t option - ; message_template : string option + ; message_template : Pool_common.MessageTemplateLabel.t option ; job_ctx : Pool_queue.job_ctx option } @@ -300,12 +355,12 @@ val pp_dispatch : Format.formatter -> dispatch -> unit val yojson_of_dispatch : dispatch -> Yojson.Safe.t val job : dispatch -> Service.Job.t val id : dispatch -> Pool_queue.Id.t option -val message_template : dispatch -> string option +val message_template : dispatch -> Pool_common.MessageTemplateLabel.t option val job_ctx : dispatch -> Pool_queue.job_ctx option val create_dispatch : ?id:Pool_queue.Id.t - -> ?message_template:string + -> ?message_template:Pool_common.MessageTemplateLabel.t -> ?job_ctx:Pool_queue.job_ctx -> Service.Job.t -> dispatch @@ -326,7 +381,7 @@ val verification_event_name : verification_event -> string val create_sent : ?id:Pool_queue.Id.t - -> ?message_template:string + -> ?message_template:Pool_common.MessageTemplateLabel.t -> ?job_ctx:Pool_queue.job_ctx -> ?new_email_address:Pool_user.EmailAddress.t -> ?new_smtp_auth_id:SmtpAuth.Id.t diff --git a/pool/app/email/email_service.ml b/pool/app/email/email_service.ml index 5825d3c9f..d85844edc 100644 --- a/pool/app/email/email_service.ml +++ b/pool/app/email/email_service.ml @@ -338,6 +338,21 @@ let register () = module Job = struct include Entity.Job + let is_system_email_template + (database_label : Database.Label.t) + (template : Pool_common.MessageTemplateLabel.t) + : bool Lwt.t + = + let open Utils.Lwt_result.Infix in + Settings.find_system_email_templates database_label + ||> (CCList.mem ~eq:Pool_common.MessageTemplateLabel.equal) template + ;; + + let resolve_system_smtp_auth_id database_label = + let%lwt auth = Repo_sql.Smtp.find_full_system_or_default_opt database_label in + auth |> CCOption.map SmtpAuth.Write.(fun { id; _ } -> id) |> Lwt.return + ;; + let encode = yojson_of_t %> Yojson.Safe.to_string let decode str = @@ -361,21 +376,54 @@ module Job = struct ;; let send = - let open CCFun in let open Utils.Lwt_result.Infix in - let open Pool_queue in - let handle ?id:_ label ({ email; smtp_auth_id; _ } : t) = + let increment_smtp_bounce = Repo_sql.Contact.increment_smtp_bounce in + let reset_smtp_bounce = Repo_sql.Contact.reset_smtp_bounce in + let is_recipient_not_found msg = + (* + Error Documentation: + * https://learn.microsoft.com/en-us/troubleshoot/exchange/email-delivery/ndr/recipientnotfound-ndr + *) + CCString.find ~sub:"550" msg >= 0 + && CCString.find ~sub:"RESOLVER.ADR.RecipientNotFound" msg >= 0 + in + let handle ?id:_ label (job : t) = + let email_data = email job in + let smtp_auth_id = smtp_auth_id job in Lwt.catch - (fun () -> send ?smtp_auth_id label email ||> CCResult.return) - (Printexc.to_string %> Pool_message.Error.nothandled %> Lwt.return_error) + (fun () -> + let%lwt result = + Smtp.send ?smtp_auth_id label email_data ||> CCResult.return + in + let%lwt () = + reset_smtp_bounce + label + (Pool_user.EmailAddress.of_string email_data.Sihl_email.recipient) + in + Lwt.return result) + (fun exn -> + match Printexc.to_string exn with + | msg when is_recipient_not_found msg -> + let recipient = email_data.Sihl_email.recipient in + Logs.info ~src (fun m -> + m + ~tags:(Database.Logger.Tags.create label) + "SMTP 550 bounce for %s — incrementing smtp_bounces_count" + recipient); + let%lwt () = + increment_smtp_bounce label (Pool_user.EmailAddress.of_string recipient) + in + Lwt.return_error (Pool_message.Error.SmtpRecipientNotFound recipient) + | msg -> Lwt.return_error (Pool_message.Error.nothandled msg)) in - Job.create - ~max_tries:10 - ~retry_delay:(Sihl.Time.Span.hours 1) - handle - encode - decode - JobName.SendEmail + Pool_queue.( + Job.create + ~max_tries:10 + ~retry_delay:(Sihl.Time.Span.hours 1) + handle + encode + decode + JobName.SendEmail) ;; end @@ -390,7 +438,16 @@ let dispatch = let tags = Database.Logger.Tags.create database_label in Logs.debug ~src (fun m -> m ~tags "Dispatch email to %s" email.Sihl_email.recipient); - let job = job |> Job.update ?new_email_address ?new_smtp_auth_id in + let%lwt resolved = + match new_smtp_auth_id, Job.smtp_auth_id job, message_template with + | Some id, _, _ -> Lwt.return_some id + | None, Some _, _ | None, None, None -> Lwt.return_none + | None, None, Some template -> + (match%lwt Job.is_system_email_template database_label template with + | true -> Job.resolve_system_smtp_auth_id database_label + | false -> Lwt.return_none) + in + let job = job |> Job.update ?new_email_address ?new_smtp_auth_id:resolved in Pool_queue.dispatch ?id ?message_template @@ -401,18 +458,37 @@ let dispatch ;; let dispatch_all database_label jobs = - let recipients, jobs = - jobs - |> CCList.fold_left - (fun (recipients, jobs) - (id, ({ Entity.Job.email; _ } as job), message_template, mappings) -> - ( email.Sihl_email.recipient :: recipients - , ( id - , job |> Job.intercept_prepare_of_event - , message_template - , CCOption.get_or ~default:(Pool_queue.job_ctx_create []) mappings ) - :: jobs )) - ([], []) + let system_template_cache = Hashtbl.create 4 in + let resolved_system_smtp_auth_id = ref None in + let%lwt recipients, jobs = + Lwt_list.fold_left_s + (fun (recipients, jobs) + (id, ({ Entity.Job.email; _ } as job), message_template, mappings) -> + let%lwt resolved_new_smtp_auth_id = + match Job.smtp_auth_id job, message_template with + | Some _, _ -> Lwt.return_none + | None, Some template -> + let%lwt is_system_template = + Utils.Lwt_cache.cached system_template_cache template (fun () -> + Job.is_system_email_template database_label template) + in + (match is_system_template with + | true -> + Utils.Lwt_cache.once resolved_system_smtp_auth_id (fun () -> + Job.resolve_system_smtp_auth_id database_label) + | false -> Lwt.return_none) + | None, _ -> Lwt.return_none + in + let job = job |> Job.update ?new_smtp_auth_id:resolved_new_smtp_auth_id in + Lwt.return + ( email.Sihl_email.recipient :: recipients + , ( id + , job |> Job.intercept_prepare_of_event + , message_template + , CCOption.get_or ~default:(Pool_queue.job_ctx_create []) mappings ) + :: jobs )) + ([], []) + jobs in Logs.debug ~src (fun m -> m diff --git a/pool/app/email/entity_smtp.ml b/pool/app/email/entity_smtp.ml index 85948959f..f53337203 100644 --- a/pool/app/email/entity_smtp.ml +++ b/pool/app/email/entity_smtp.ml @@ -80,6 +80,49 @@ module Default = struct let schema = schema Pool_message.Field.DefaultSmtpServer end +module InternalRegex = struct + include Pool_model.Base.String + + let field = Pool_message.Field.SmtpInternalRegex + let schema () = schema field () +end + +module SystemAccount = struct + include Pool_model.Base.Boolean + + let init = false + let schema = schema Pool_message.Field.SmtpSystemAccount +end + +module RateLimit = struct + include Pool_model.Base.Integer + + let field = Pool_message.Field.SmtpRateLimit + let default : t = of_int 86400 (* 24h in seconds *) + let timediff_seconds = 86400 (* 24h in seconds *) + + let create n = + if n >= 0 then Ok n else Error Pool_message.(Error.Invalid Field.SmtpRateLimit) + ;; + + let schema = schema field create +end + +module InvitationCapacity = struct + include Pool_model.Base.Integer + + let field = Pool_message.Field.SmtpInvitationCapacity + let default : t = of_int 80 + + let create n = + if n >= 0 && n <= 100 + then Ok n + else Error Pool_message.(Error.Invalid Field.SmtpInvitationCapacity) + ;; + + let schema = schema field create +end + type t = { id : Id.t ; label : Label.t @@ -89,6 +132,10 @@ type t = ; mechanism : Mechanism.t ; protocol : Protocol.t ; default : Default.t + ; system_account : SystemAccount.t + ; internal_regex : InternalRegex.t option [@sexp.option] + ; rate_limit : RateLimit.t + ; invitation_capacity : InvitationCapacity.t } [@@deriving eq, fields ~getters, show, sexp_of] @@ -123,10 +170,28 @@ module Write = struct ; mechanism : Mechanism.t ; protocol : Protocol.t ; default : Default.t + ; system_account : SystemAccount.t + ; internal_regex : InternalRegex.t option + ; rate_limit : RateLimit.t + ; invitation_capacity : InvitationCapacity.t } [@@deriving eq, show] - let create ?id label server port username password mechanism protocol default = + let create + ?id + ?(rate_limit = RateLimit.default) + ?(invitation_capacity = InvitationCapacity.default) + ?(system_account = SystemAccount.create false) + ?internal_regex + label + server + port + username + password + mechanism + protocol + default + = let open CCResult.Infix in let* mechanism = validate_mechanism mechanism username password in Ok @@ -139,6 +204,10 @@ module Write = struct ; mechanism ; protocol ; default + ; system_account + ; internal_regex + ; rate_limit + ; invitation_capacity } ;; @@ -151,6 +220,10 @@ module Write = struct ; mechanism = t.mechanism ; protocol = t.protocol ; default = t.default + ; system_account = t.system_account + ; internal_regex = t.internal_regex + ; rate_limit = t.rate_limit + ; invitation_capacity = t.invitation_capacity } ;; end @@ -176,6 +249,10 @@ let column_smtp_default_account = (Field.DefaultSmtpServer, "pool_smtp.default_account") |> Query.Column.create ;; +let column_smtp_system_account = + (Field.SmtpSystemAccount, "pool_smtp.system_account") |> Query.Column.create +;; + let column_created_at = (Field.CreatedAt, "pool_smtp.created_at") |> Query.Column.create let searchable_by = @@ -188,7 +265,11 @@ let searchable_by = ;; let default_sort_column = column_created_at -let sortable_by = [ column_created_at; column_smtp_default_account ] @ searchable_by + +let sortable_by = + [ column_created_at; column_smtp_default_account; column_smtp_system_account ] + @ searchable_by +;; let default_sort = Query.Sort.{ column = default_sort_column; order = SortOrder.Descending } diff --git a/pool/app/email/event.ml b/pool/app/email/event.ml index c4968e5ef..b52e419b7 100644 --- a/pool/app/email/event.ml +++ b/pool/app/email/event.ml @@ -1,4 +1,3 @@ -open Ppx_yojson_conv_lib.Yojson_conv.Primitives open Entity module User = Pool_user @@ -46,7 +45,7 @@ let pp_verification_event formatter (event : verification_event) : unit = type dispatch = { job : Job.t ; id : Pool_queue.Id.t option [@yojson.option] - ; message_template : string option [@yojson.option] + ; message_template : Pool_common.MessageTemplateLabel.t option [@yojson.option] ; job_ctx : Pool_queue.job_ctx option [@yojson.option] } [@@deriving eq, fields, show, yojson] diff --git a/pool/app/email/repo/repo.ml b/pool/app/email/repo/repo.ml index 0d869d816..564df8124 100644 --- a/pool/app/email/repo/repo.ml +++ b/pool/app/email/repo/repo.ml @@ -17,6 +17,7 @@ module Smtp = struct let find_default = Sql.Smtp.find_default let find_default_opt = Sql.Smtp.find_default_opt let find_all = Sql.Smtp.find_all + let find_for_experiment = Sql.Smtp.find_for_experiment let insert = Sql.Smtp.insert let update = Sql.Smtp.update let delete = Sql.Smtp.delete @@ -25,5 +26,7 @@ module Smtp = struct Sql.Smtp.update_password label (id, password) ;; + let count_invitations_sent_since = Sql.Smtp.count_invitations_sent_since + module RepoEntity = Repo_entity_smtp_auth end diff --git a/pool/app/email/repo/repo_entity_smtp_auth.ml b/pool/app/email/repo/repo_entity_smtp_auth.ml index 1a8fcb433..dccd7306d 100644 --- a/pool/app/email/repo/repo_entity_smtp_auth.ml +++ b/pool/app/email/repo/repo_entity_smtp_auth.ml @@ -53,16 +53,77 @@ module Default = struct ;; end +module RateLimit = struct + include RateLimit + + let t = Pool_common.Repo.make_caqti_type Caqti_type.int create value +end + +module InvitationCapacity = struct + include InvitationCapacity + + let t = Pool_common.Repo.make_caqti_type Caqti_type.int create value +end + +module SystemAccount = struct + include SystemAccount + + let t = + Pool_common.Repo.make_caqti_type + Caqti_type.bool + CCFun.(create %> CCResult.return) + value + ;; +end + +module InternalRegex = struct + include InternalRegex + + let t = Pool_common.Repo.make_caqti_type Caqti_type.string create value +end + let t = let encode (m : t) = Ok ( m.id , ( m.label - , (m.server, (m.port, (m.username, (m.mechanism, (m.protocol, m.default))))) ) ) + , ( m.server + , ( m.port + , ( m.username + , ( m.mechanism + , ( m.protocol + , ( m.default + , ( m.system_account + , (m.internal_regex, (m.rate_limit, m.invitation_capacity)) ) ) ) ) + ) ) ) ) ) in - let decode (id, (label, (server, (port, (username, (mechanism, (protocol, default))))))) + let decode + ( id + , ( label + , ( server + , ( port + , ( username + , ( mechanism + , ( protocol + , ( default + , ( system_account + , (internal_regex, (rate_limit, invitation_capacity)) ) ) ) ) ) ) + ) ) ) = - Ok { id; label; server; port; username; mechanism; protocol; default } + Ok + { id + ; label + ; server + ; port + ; username + ; mechanism + ; protocol + ; default + ; system_account + ; internal_regex + ; rate_limit + ; invitation_capacity + } in Caqti_type.( custom @@ -76,7 +137,19 @@ let t = Server.t (t2 Port.t - (t2 (option Username.t) (t2 Mechanism.t (t2 Protocol.t Default.t)))))))) + (t2 + (option Username.t) + (t2 + Mechanism.t + (t2 + Protocol.t + (t2 + Default.t + (t2 + SystemAccount.t + (t2 + (option InternalRegex.t) + (t2 RateLimit.t InvitationCapacity.t)))))))))))) ;; module Write = struct @@ -88,17 +161,45 @@ module Write = struct ( m.id , ( m.label , ( m.server - , (m.port, (m.username, (m.password, (m.mechanism, (m.protocol, m.default))))) - ) ) ) + , ( m.port + , ( m.username + , ( m.password + , ( m.mechanism + , ( m.protocol + , ( m.default + , ( m.system_account + , (m.internal_regex, (m.rate_limit, m.invitation_capacity)) ) ) + ) ) ) ) ) ) ) ) in let decode ( id , ( label - , (server, (port, (username, (password, (mechanism, (protocol, default)))))) - ) ) + , ( server + , ( port + , ( username + , ( password + , ( mechanism + , ( protocol + , ( default + , ( system_account + , (internal_regex, (rate_limit, invitation_capacity)) ) ) ) ) + ) ) ) ) ) ) = - let open CCResult in - Ok { id; label; server; port; username; password; mechanism; protocol; default } + Ok + { id + ; label + ; server + ; port + ; username + ; password + ; mechanism + ; protocol + ; default + ; system_account + ; internal_regex + ; rate_limit + ; invitation_capacity + } in Caqti_type.( custom @@ -114,6 +215,18 @@ module Write = struct Port.t (t2 (option Username.t) - (t2 (option Password.t) (t2 Mechanism.t (t2 Protocol.t Default.t))))))))) + (t2 + (option Password.t) + (t2 + Mechanism.t + (t2 + Protocol.t + (t2 + Default.t + (t2 + SystemAccount.t + (t2 + (option InternalRegex.t) + (t2 RateLimit.t InvitationCapacity.t))))))))))))) ;; end diff --git a/pool/app/email/repo/repo_sql.ml b/pool/app/email/repo/repo_sql.ml index 713c4bab2..e87d7f332 100644 --- a/pool/app/email/repo/repo_sql.ml +++ b/pool/app/email/repo/repo_sql.ml @@ -166,7 +166,11 @@ module Smtp = struct %s mechanism, protocol, - default_account + default_account, + system_account, + internal_regex, + rate_limit, + invitation_capacity FROM pool_smtp |sql} with_password_fragment @@ -221,6 +225,21 @@ module Smtp = struct Database.find_opt pool find_full_default_request () ||> CCOption.to_result not_found ;; + let find_full_system_or_default_request = + let open Caqti_request.Infix in + {sql| + WHERE COALESCE(system_account, default_account) = 1 + ORDER BY system_account DESC, default_account DESC + LIMIT 1 + |sql} + |> select_smtp_sql ~with_password:true + |> Caqti_type.unit ->! RepoEntity.SmtpAuth.Write.t + ;; + + let find_full_system_or_default_opt pool = + Database.find_opt pool find_full_system_or_default_request () + ;; + let find_default_request = let open Caqti_request.Infix in {sql| @@ -245,6 +264,15 @@ module Smtp = struct let find_all pool = Database.collect pool find_all_request () + let find_for_experiment_request = + let open Caqti_request.Infix in + {sql|WHERE system_account = 0|sql} + |> select_smtp_sql + |> Caqti_type.unit ->* RepoEntity.SmtpAuth.t + ;; + + let find_for_experiment pool = Database.collect pool find_for_experiment_request () + let select_count where_fragment = Format.asprintf {sql| @@ -287,7 +315,11 @@ module Smtp = struct password, mechanism, protocol, - default_account + default_account, + system_account, + internal_regex, + rate_limit, + invitation_capacity ) VALUES ( UNHEX(REPLACE(?, '-', '')), ?, @@ -297,6 +329,10 @@ module Smtp = struct ?, ?, ?, + ?, + ?, + ?, + ?, ? ) |sql} @@ -323,7 +359,11 @@ module Smtp = struct username = $5, mechanism = $6, protocol = $7, - default_account = $8 + default_account = $8, + system_account = $9, + internal_regex = $10, + rate_limit = $11, + invitation_capacity = $12 WHERE uuid = UNHEX(REPLACE($1, '-', '')) |sql} @@ -363,4 +403,107 @@ module Smtp = struct ;; let update_password pool = Database.exec pool update_password_request + + (* Count invitations sent in the last [window] seconds for the given smtp_auth_id + (or the default account when None). Join path: + pool_invitations → pool_experiments → pool_smtp *) + let count_invitations_sent_since_default_request = + let open Caqti_request.Infix in + {sql| + SELECT COUNT(*) + FROM pool_invitations + INNER JOIN pool_experiments + ON pool_invitations.experiment_uuid = pool_experiments.uuid + INNER JOIN pool_smtp + ON ( + pool_experiments.smtp_auth_uuid = pool_smtp.uuid + OR (pool_experiments.smtp_auth_uuid IS NULL + AND pool_smtp.default_account = 1) + ) + INNER JOIN user_users + ON pool_invitations.contact_uuid = user_users.uuid + WHERE pool_invitations.created_at >= DATE_SUB(NOW(), INTERVAL ? SECOND) + AND pool_smtp.default_account = 1 + AND (pool_smtp.internal_regex IS NULL + OR user_users.email NOT REGEXP pool_smtp.internal_regex) + |sql} + |> Caqti_type.(int ->! int) + ;; + + let count_invitations_sent_since_id_request = + let open Caqti_request.Infix in + {sql| + SELECT COUNT(*) + FROM pool_invitations + INNER JOIN pool_experiments + ON pool_invitations.experiment_uuid = pool_experiments.uuid + INNER JOIN pool_smtp + ON pool_experiments.smtp_auth_uuid = pool_smtp.uuid + INNER JOIN user_users + ON pool_invitations.contact_uuid = user_users.uuid + WHERE pool_invitations.created_at >= DATE_SUB(NOW(), INTERVAL ? SECOND) + AND pool_smtp.uuid = UNHEX(REPLACE(?, '-', '')) + AND (pool_smtp.internal_regex IS NULL + OR user_users.email NOT REGEXP pool_smtp.internal_regex) + |sql} + |> Caqti_type.(t2 int RepoEntity.SmtpAuth.Id.t ->! int) + ;; + + (* [count_invitations_sent_since pool smtp_auth_id window_seconds] returns the + number of invitations sent in the last [window_seconds] seconds via experiments + using the given SMTP account (or the default account when smtp_auth_id is None). *) + let count_invitations_sent_since pool smtp_auth_id window_seconds = + match smtp_auth_id with + | None -> + Database.find pool count_invitations_sent_since_default_request window_seconds + | Some id -> + Database.find pool count_invitations_sent_since_id_request (window_seconds, id) + ;; +end + +module Contact = struct + let increment_smtp_bounce_request = + (* if the new count reaches or exceeds 5 the contact is also paused + and paused_version is incremented. *) + let open Caqti_request.Infix in + {sql| + UPDATE pool_contacts + INNER JOIN user_users + ON pool_contacts.user_uuid = user_users.uuid + SET + pool_contacts.smtp_bounces_count = + LEAST(pool_contacts.smtp_bounces_count + 1, 32767), + pool_contacts.paused = + CASE WHEN pool_contacts.smtp_bounces_count + 1 >= 5 THEN 1 + ELSE pool_contacts.paused + END, + pool_contacts.paused_version = + CASE WHEN pool_contacts.smtp_bounces_count + 1 >= 5 + THEN pool_contacts.paused_version + 1 + ELSE pool_contacts.paused_version + END + WHERE user_users.email = ? + AND user_users.admin = 0 + |sql} + |> Pool_user.Repo.EmailAddress.t ->. Caqti_type.unit + ;; + + let increment_smtp_bounce pool email = + Database.exec pool increment_smtp_bounce_request email + ;; + + let reset_smtp_bounce_request = + let open Caqti_request.Infix in + {sql| + UPDATE pool_contacts + INNER JOIN user_users + ON pool_contacts.user_uuid = user_users.uuid + SET pool_contacts.smtp_bounces_count = 0 + WHERE user_users.email = ? + AND user_users.admin = 0 + |sql} + |> Pool_user.Repo.EmailAddress.t ->. Caqti_type.unit + ;; + + let reset_smtp_bounce pool email = Database.exec pool reset_smtp_bounce_request email end diff --git a/pool/app/message_template/default/locales/default_de.ml b/pool/app/message_template/default/locales/default_de.ml index f46efd68a..10e0a45b5 100644 --- a/pool/app/message_template/default/locales/default_de.ml +++ b/pool/app/message_template/default/locales/default_de.ml @@ -1,6 +1,7 @@ open Entity open Message_utils open Tyxml.Html +open Pool_common.MessageTemplateLabel let language = Pool_common.Language.De let entity_uuid = None @@ -22,7 +23,7 @@ let add_salutation_to_text = let add_salutation html = div ((salutation :: html) @ [ complimentary_close ]) let account_suspension_notification = - let label = Label.AccountSuspensionNotification in + let label = AccountSuspensionNotification in let email_text = [ p [ txt @@ -59,7 +60,7 @@ Wenn diese Versuche nicht von Ihnen durchgeführt wurden, informieren Sie bitte ;; let assignment_confirmation = - let label = Label.AssignmentConfirmation in + let label = AssignmentConfirmation in let email_text = [ p [ txt @@ -96,7 +97,7 @@ Die Teilnahme ist obligatorisch.|} ;; let assignment_session_change = - let label = Label.AssignmentSessionChange in + let label = AssignmentSessionChange in let email_text = [ p [ txt "Sie wurden einer neuen Session zugewiesen:" @@ -133,7 +134,7 @@ An der Session vom {oldSessionStart} sind Sie nicht mehr angemeldet.|} ;; let email_verification = - let label = Label.EmailVerification in + let label = EmailVerification in let email_text = [ p [ txt "Du hast kürzlich eine neue E-Mail-Adresse zu deinem Account hinzugefügt." @@ -179,7 +180,7 @@ Wenn Sie diese Aktion nicht ausgeführt haben, dann ignorieren Sie diese E-Mail ;; let experiment_invitation = - let label = Label.ExperimentInvitation in + let label = ExperimentInvitation in let email_text = [ p [ txt "Wir möchten Sie zu einem bevorstehenden Experiment einladen:" ] ; p [ strong [ txt "{experimentPublicTitle}" ] ] @@ -222,7 +223,7 @@ Informationen zu den Sessions finden Sie hier: {experimentUrl}|} ;; let password_change = - let label = Label.PasswordChange in + let label = PasswordChange in let email_text = [ p [ txt "Du hast kürzlich das Passwort deines Accounts geändert." ] ; p @@ -255,7 +256,7 @@ Wenn du dein Passwort nicht geändert hast, dann kontaktiere uns bitte umgehend. ;; let phone_verification = - let label = Label.PhoneVerification in + let label = PhoneVerification in let email_text = "Ihr Code zur Verifizierung Ihrer Mobiltelefonnummer: {token}" |> EmailText.of_string in @@ -275,7 +276,7 @@ let phone_verification = ;; let profile_update_trigger = - let label = Label.ProfileUpdateTrigger in + let label = ProfileUpdateTrigger in let email_text = [ p [ txt "Ihr Profil wurde schon länger nicht aktualisiert." ] ; p @@ -308,7 +309,7 @@ Bitte kontrollieren Sie die Angaben in Ihrem Profil: {profileUrl}|} ;; let password_reset = - let label = Label.PasswordReset in + let label = PasswordReset in let email_text = [ p [ txt @@ -356,7 +357,7 @@ Wenn du dies nicht beantragt hast, kannst du diese E-Mail ignorieren oder mit un ;; let signup_verification = - let label = Label.SignUpVerification in + let label = SignUpVerification in let email_text = [ p [ txt "Vielen Dank für deine Anmeldung beim Pool Tool." @@ -403,7 +404,7 @@ Wenn du dies nicht beantragt hast, kannst du diese E-Mail ignorieren oder mit un ;; let session_cancellation = - let label = Label.SessionCancellation in + let label = SessionCancellation in let email_text = [ p [ txt "Die folgende Session, zu der du angemeldet warst, wurde abgesagt:" ] ; p [ txt "{sessionOverview}" ] @@ -437,7 +438,7 @@ Grund: {reason} ;; let session_reminder = - let label = Label.SessionReminder in + let label = SessionReminder in let email_text = [ p [ txt "Hiermit erinnern wir Sie an die Experiment-Session:" @@ -469,7 +470,7 @@ let session_reminder = ;; let session_reschedule = - let label = Label.SessionReschedule in + let label = SessionReschedule in let email_text = [ p [ txt "Eine Session, zu der Sie angemeldet sind, wurde verschoben:" @@ -513,7 +514,7 @@ Neu: ;; let contact_registration_attempt = - let label = Label.ContactRegistrationAttempt in + let label = ContactRegistrationAttempt in let email_text = [ p [ txt @@ -567,7 +568,7 @@ let contact_registration_attempt = ;; let user_import = - let label = Label.UserImport in + let label = UserImport in let email_text = [ p [ txt "Ihr Account wurde kürzlich migriert." @@ -606,7 +607,7 @@ let user_import = ;; let waiting_list_confirmation = - let label = Label.WaitingListConfirmation in + let label = WaitingListConfirmation in let email_text = [ p [ txt diff --git a/pool/app/message_template/default/locales/default_en.ml b/pool/app/message_template/default/locales/default_en.ml index 680ce308e..b665efedf 100644 --- a/pool/app/message_template/default/locales/default_en.ml +++ b/pool/app/message_template/default/locales/default_en.ml @@ -1,6 +1,7 @@ open Entity open Message_utils open Tyxml.Html +open Pool_common.MessageTemplateLabel let language = Pool_common.Language.En let entity_uuid = None @@ -14,7 +15,7 @@ let add_salutation_to_text = let add_salutation html = div ((salutation :: html) @ [ complimentary_close ]) let account_suspension_notification = - let label = Label.AccountSuspensionNotification in + let label = AccountSuspensionNotification in let email_text = [ p [ txt @@ -49,7 +50,7 @@ If these attempts were not made by you, please inform an administrator.|} ;; let assignment_confirmation = - let label = Label.AssignmentConfirmation in + let label = AssignmentConfirmation in let email_text = [ p [ txt "You successfully registered to the following session/s:" @@ -84,7 +85,7 @@ The participation in the session is compulsory.|} ;; let assignment_session_change = - let label = Label.AssignmentSessionChange in + let label = AssignmentSessionChange in let email_text = [ p [ txt "You have been assigned to a new session:"; br (); txt "{sessionOverview}" ] ; p [ txt "You are no longer signed up for the session on {oldSessionStart}." ] @@ -117,7 +118,7 @@ You are no longer signed up for the session on {oldSessionStart}.|} ;; let email_verification = - let label = Label.EmailVerification in + let label = EmailVerification in let email_text = [ p [ txt "You recently added a new email address to your account." @@ -164,7 +165,7 @@ If this action wasn`t performed by you, please ignore this email or reply to let ;; let experiment_invitation = - let label = Label.ExperimentInvitation in + let label = ExperimentInvitation in let email_text = [ p [ txt "We would like to invite you to the following experiment:" ] ; p [ strong [ txt "{experimentPublicTitle}" ] ] @@ -207,7 +208,7 @@ Information about the sessions can be found here: {experimentUrl}|} ;; let password_change = - let label = Label.PasswordChange in + let label = PasswordChange in let email_text = [ p [ txt {|You recently changed your password for your account.|} ] ; p [ txt "If you did not change your password, please get in contact with us." ] @@ -236,7 +237,7 @@ If you did not change your password, please get in contact with us.|} ;; let phone_verification = - let label = Label.PhoneVerification in + let label = PhoneVerification in let email_text = "Your phone number verification code: {token}" |> EmailText.of_string in @@ -254,7 +255,7 @@ let phone_verification = ;; let profile_update_trigger = - let label = Label.ProfileUpdateTrigger in + let label = ProfileUpdateTrigger in let email_text = [ p [ txt "Your profile has not been updated in a while." ] ; p @@ -287,7 +288,7 @@ Please check your profile: {profileUrl}|} ;; let password_reset = - let label = Label.PasswordReset in + let label = PasswordReset in let email_text = [ p [ txt "You recently requested to reset your password for your account." @@ -336,7 +337,7 @@ hour.|} ;; let signup_verification = - let label = Label.SignUpVerification in + let label = SignUpVerification in let email_text = [ p [ txt "Thank your for signing up for the Pool Tool." @@ -383,7 +384,7 @@ If this action wasn`t performed by you, please ignore this email or reply to let ;; let session_cancellation = - let label = Label.SessionCancellation in + let label = SessionCancellation in let email_text = [ p [ txt "The following session you have registered to was canceled:" ] ; p [ txt "{sessionOverview}" ] @@ -416,7 +417,7 @@ Reason: {reason}|} ;; let session_reminder = - let label = Label.SessionReminder in + let label = SessionReminder in let email_text = [ p [ txt "Herewith we remind you about your upcoming experiment session:" @@ -448,7 +449,7 @@ let session_reminder = ;; let session_reschedule = - let label = Label.SessionReschedule in + let label = SessionReschedule in let email_text = [ p [ txt "The following session you have registered to was rescheduled:" @@ -492,7 +493,7 @@ New: ;; let contact_registration_attempt = - let label = Label.ContactRegistrationAttempt in + let label = ContactRegistrationAttempt in let email_text = [ p [ txt @@ -546,7 +547,7 @@ If this action was not performed by you, you can ignore this message or inform t ;; let user_import = - let label = Label.UserImport in + let label = UserImport in let email_text = [ p [ txt "Your account was recently migrated." @@ -585,7 +586,7 @@ let user_import = ;; let waiting_list_confirmation = - let label = Label.WaitingListConfirmation in + let label = WaitingListConfirmation in let email_text = [ p [ txt diff --git a/pool/app/message_template/entity.ml b/pool/app/message_template/entity.ml index 8dbc0e962..5b161840d 100644 --- a/pool/app/message_template/entity.ml +++ b/pool/app/message_template/entity.ml @@ -9,81 +9,6 @@ module Id = struct include Pool_common.Id end -module Label = struct - let print = Utils.ppx_printer - - type t = - | AccountSuspensionNotification [@name "account_suspension_notification"] - [@printer print "account_suspension_notification"] - | AssignmentCancellation [@name "assignment_cancellation"] - [@printer print "assignment_cancellation"] - | AssignmentConfirmation [@name "assignment_confirmation"] - [@printer print "assignment_confirmation"] - | AssignmentSessionChange [@name "assignment_session_change"] - [@printer print "assignment_session_change"] - | ContactEmailChangeAttempt [@name "contact_email_change_attempt"] - [@printer print "contact_email_change_attempt"] - | ContactRegistrationAttempt [@name "contact_registration_attempt"] - [@printer print "contact_registration_attempt"] - | EmailVerification [@name "email_verification"] [@printer print "email_verification"] - | ExperimentInvitation [@name "experiment_invitation"] - [@printer print "experiment_invitation"] - | InactiveContactWarning [@name "inactive_contact_warning"] - [@printer print "inactive_contact_warning"] - | InactiveContactDeactivation [@name "inactive_contact_deactivation"] - [@printer print "inactive_contact_deactivation"] - | Login2FAToken [@name "login_2fa_token"] [@printer print "login_2fa_token"] - | ManualSessionMessage [@name "manual_session_message"] - [@printer print "manual_session_message"] - | MatcherNotification [@name "matcher_notification"] - [@printer print "matcher_notification"] - | MatchFilterUpdateNotification [@name "match_filter_update_notification"] - [@printer print "match_filter_update_notification"] - | PasswordChange [@name "password_change"] [@printer print "password_change"] - | PasswordReset [@name "password_reset"] [@printer print "password_reset"] - | PhoneVerification [@name "phone_verification"] [@printer print "phone_verification"] - | ProfileUpdateTrigger [@name "profile_update_trigger"] - [@printer print "profile_update_trigger"] - | SignUpVerification [@name "signup_verification"] - [@printer print "signup_verification"] - | SessionCancellation [@name "session_cancellation"] - [@printer print "session_cancellation"] - | SessionReminder [@name "session_reminder"] [@printer print "session_reminder"] - | SessionReschedule [@name "session_reschedule"] [@printer print "session_reschedule"] - | UserImport [@name "user_import"] [@printer print "user_import"] - | WaitingListConfirmation [@name "waiting_list_confirmation"] - [@printer print "waiting_list_confirmation"] - [@@deriving eq, show { with_path = false }, yojson, variants] - - let read = Utils.Json.read_variant t_of_yojson - let read_from_url m = m |> CCString.replace ~which:`All ~sub:"-" ~by:"_" |> read - - let of_string str = - try Ok (read str) with - | _ -> Error Pool_message.(Error.Invalid Field.Label) - ;; - - let to_human m = - m |> show |> CCString.replace ~sub:"_" ~by:" " |> CCString.capitalize_ascii - ;; - - let human_url m = m |> show |> CCString.replace ~sub:"_" ~by:"-" - - let prefixed_human_url m = - m - |> human_url - |> Format.asprintf "%s/%s" Pool_message.Field.(human_url MessageTemplate) - ;; - - let customizable_by_experiment = - [ ExperimentInvitation - ; SessionReminder - ; AssignmentConfirmation - ; WaitingListConfirmation - ] - ;; -end - module EmailSubject = struct include Pool_model.Base.String @@ -120,7 +45,7 @@ end type t = { id : Id.t - ; label : Label.t + ; label : Pool_common.MessageTemplateLabel.t ; entity_uuid : Pool_common.Id.t option ; language : Pool_common.Language.t ; email_subject : EmailSubject.t @@ -145,15 +70,20 @@ type layout = | Tenant of Pool_tenant.t | Root -let to_human_label m = m.label |> Label.to_human +let to_human_label m = m.label |> Pool_common.MessageTemplateLabel.to_human let prefixed_template_url ?append m = - let base = Format.asprintf "%s/%s" (Label.prefixed_human_url m.label) (Id.value m.id) in + let base = + Format.asprintf + "%s/%s" + (Pool_common.MessageTemplateLabel.prefixed_human_url m.label) + (Id.value m.id) + in append |> CCOption.map_or ~default:base (Format.asprintf "%s/%s" base) ;; let template_hint label = - let open Label in + let open Pool_common.MessageTemplateLabel in let open Pool_common.I18n in match label with | AccountSuspensionNotification -> MessageTemplateAccountSuspensionNotification diff --git a/pool/app/message_template/message_template.ml b/pool/app/message_template/message_template.ml index e2fd851b9..62e27d739 100644 --- a/pool/app/message_template/message_template.ml +++ b/pool/app/message_template/message_template.ml @@ -5,9 +5,18 @@ include Message_utils module Guard = Entity_guard module VersionHistory = Version_history module Queue = Pool_queue +open Pool_common.MessageTemplateLabel let src = Logs.Src.create "message_template" +let customizable_label_by_experiment = + [ ExperimentInvitation + ; SessionReminder + ; AssignmentConfirmation + ; WaitingListConfirmation + ] +;; + module History = struct open Queue.History @@ -31,14 +40,12 @@ end let create_email_job ?smtp_auth_id label mapping_uuids email = Email.Service.Job.create ?smtp_auth_id email |> Email.create_dispatch - ~message_template:(Label.show label) + ~message_template:label ~job_ctx:(Queue.job_ctx_create mapping_uuids) ;; let create_text_message_job ?message_template ?(entity_uuids = []) = - Text_message.create_job - ?message_template:(CCOption.map Label.show message_template) - ~job_ctx:(Queue.job_ctx_create entity_uuids) + Text_message.create_job ?message_template ~job_ctx:(Queue.job_ctx_create entity_uuids) ;; let find = Repo.find @@ -279,7 +286,7 @@ let session_message_uuids experiment session contact = module AccountSuspensionNotification = struct let email_params = global_params - let label = Label.AccountSuspensionNotification + let label = AccountSuspensionNotification let create ({ Pool_tenant.database_label; _ } as tenant) user = let open Message_utils in @@ -306,7 +313,7 @@ end module AssignmentCancellation = struct open Assignment - let label = Label.AssignmentCancellation + let label = AssignmentCancellation let base_params layout contact = contact.Contact.user |> global_params layout let email_params ?follow_up_sessions language layout experiment session assignment = @@ -350,7 +357,7 @@ end module AssignmentConfirmation = struct open Assignment - let label = Label.AssignmentConfirmation + let label = AssignmentConfirmation let base_params layout contact = contact.Contact.user |> global_params layout let email_params ?follow_up_sessions language layout experiment session assignment = @@ -395,7 +402,7 @@ module AssignmentConfirmation = struct end module AssignmentSessionChange = struct - let label = Label.AssignmentSessionChange + let label = AssignmentSessionChange let message_uuids experiment new_session old_session { Assignment.contact; _ } = History. @@ -437,7 +444,7 @@ module AssignmentSessionChange = struct end module ContactEmailChangeAttempt = struct - let label = Label.ContactEmailChangeAttempt + let label = ContactEmailChangeAttempt let email_params layout tenant_url user = let reset_url = create_public_url tenant_url "/request-reset-password" in @@ -460,10 +467,7 @@ module ContactEmailChangeAttempt = struct contact_language sys_langs contact |> Lwt_result.return in let%lwt template = - find_by_label_and_language_to_send - pool - Label.ContactEmailChangeAttempt - message_language + find_by_label_and_language_to_send pool ContactEmailChangeAttempt message_language in let layout = layout_from_tenant tenant in let tenant_url = tenant.Pool_tenant.url in @@ -483,7 +487,7 @@ module ContactEmailChangeAttempt = struct end module ContactRegistrationAttempt = struct - let label = Label.ContactRegistrationAttempt + let label = ContactRegistrationAttempt let email_params layout tenant_url user = let reset_url = create_public_url tenant_url "/request-reset-password" in @@ -515,7 +519,7 @@ module ContactRegistrationAttempt = struct end module EmailVerification = struct - let label = Label.EmailVerification + let label = EmailVerification let email_params layout validation_url contact = global_params layout contact.Contact.user @ [ "verificationUrl", validation_url ] @@ -523,7 +527,7 @@ module EmailVerification = struct let create pool language layout contact email_address token = let%lwt template = - find_by_label_and_language_to_send pool Label.EmailVerification language + find_by_label_and_language_to_send pool EmailVerification language in let layout = create_layout layout in let%lwt url = Pool_tenant.Url.of_pool pool in @@ -551,7 +555,7 @@ module EmailVerification = struct end module ExperimentInvitation = struct - let label = Label.ExperimentInvitation + let label = ExperimentInvitation let optout_link = Verified let email_params layout experiment contact = @@ -567,7 +571,7 @@ module ExperimentInvitation = struct pool ~entity_uuids:[ Experiment.(Id.to_common experiment.Experiment.id) ] sys_langs - Label.ExperimentInvitation + ExperimentInvitation in let smtp_auth_id = experiment.Experiment.smtp_auth_id in let%lwt sender = sender_of_experiment pool experiment in @@ -622,7 +626,7 @@ module ExperimentInvitation = struct end module InactiveContactWarning = struct - let label = Label.InactiveContactWarning + let label = InactiveContactWarning let email_params layout contact ~last_login = global_params layout contact.Contact.user @@ -656,7 +660,7 @@ module InactiveContactWarning = struct end module InactiveContactDeactivation = struct - let label = Label.InactiveContactDeactivation + let label = InactiveContactDeactivation let email_params layout contact = global_params layout contact.Contact.user let prepare pool = @@ -683,7 +687,7 @@ module InactiveContactDeactivation = struct end module Login2FAToken = struct - let label = Label.Login2FAToken + let label = Login2FAToken let email_params layout user token = global_params layout user @ [ "token", Authentication.Token.value token ] @@ -710,7 +714,7 @@ module Login2FAToken = struct end module ManualSessionMessage = struct - let label = Label.ManualSessionMessage + let label = ManualSessionMessage let base_params layout contact = contact.Contact.user |> global_params layout let email_params language layout experiment session assignment = @@ -759,7 +763,7 @@ module ManualSessionMessage = struct end module MatcherNotification = struct - let label = Label.MatcherNotification + let label = MatcherNotification let email_params layout user experiment = global_params layout user @ experiment_params layout experiment @@ -779,7 +783,7 @@ module MatcherNotification = struct end module MatchFilterUpdateNotification = struct - let label = Label.MatchFilterUpdateNotification + let label = MatchFilterUpdateNotification let message_uuids experiment sessions admin = let open History in @@ -836,7 +840,7 @@ end module PasswordChange = struct let email_params = global_params - let label = Label.PasswordChange + let label = PasswordChange let create language tenant user = let pool = tenant.Pool_tenant.database_label in @@ -859,7 +863,7 @@ module PasswordChange = struct end module PasswordReset = struct - let label = Label.PasswordReset + let label = PasswordReset let email_params layout reset_url user = global_params layout user @ [ "resetUrl", reset_url ] @@ -868,9 +872,7 @@ module PasswordReset = struct let create pool language layout user = let open Utils.Lwt_result.Infix in let email = Pool_user.email user in - let%lwt template = - find_by_label_and_language_to_send pool Label.PasswordReset language - in + let%lwt template = find_by_label_and_language_to_send pool PasswordReset language in let%lwt url = Pool_tenant.Url.of_pool pool in let%lwt sender = default_sender_of_pool pool in let open Pool_common in @@ -908,7 +910,7 @@ module PasswordReset = struct end module PhoneVerification = struct - let label = Label.PhoneVerification + let label = PhoneVerification let message_params token = [ "token", Pool_common.VerificationCode.value token ] let create_text_message @@ -937,7 +939,7 @@ module PhoneVerification = struct end module ProfileUpdateTrigger = struct - let label = Label.ProfileUpdateTrigger + let label = ProfileUpdateTrigger let email_params layout tenant_url contact = let profile_url = create_public_url tenant_url "/user/personal-details" in @@ -947,9 +949,7 @@ module ProfileUpdateTrigger = struct let prepare pool tenant = let open Message_utils in let%lwt sys_langs = Settings.find_languages pool in - let%lwt templates = - find_all_by_label_to_send pool sys_langs Label.SessionReschedule - in + let%lwt templates = find_all_by_label_to_send pool sys_langs SessionReschedule in let%lwt url = Pool_tenant.Url.of_pool pool in let%lwt sender = default_sender_of_pool pool in let layout = layout_from_tenant tenant in @@ -974,7 +974,7 @@ module ProfileUpdateTrigger = struct end module SessionCancellation = struct - let label = Label.SessionCancellation + let label = SessionCancellation let email_params language @@ -996,9 +996,7 @@ module SessionCancellation = struct let prepare pool tenant experiment sys_langs session follow_up_sessions = let open Message_utils in - let%lwt templates = - find_all_by_label_to_send pool sys_langs Label.SessionCancellation - in + let%lwt templates = find_all_by_label_to_send pool sys_langs SessionCancellation in let%lwt sender = sender_of_experiment pool experiment in let layout = layout_from_tenant tenant in let fnc reason (contact : Contact.t) = @@ -1027,9 +1025,7 @@ module SessionCancellation = struct follow_up_sessions = let open Message_utils in - let%lwt templates = - find_all_by_label_to_send pool sys_langs Label.SessionCancellation - in + let%lwt templates = find_all_by_label_to_send pool sys_langs SessionCancellation in let%lwt gtx_config = Gtx_config.find_exn pool in let layout = layout_from_tenant tenant in let fnc reason (contact : Contact.t) cell_phone = @@ -1054,7 +1050,7 @@ module SessionCancellation = struct end module SessionReminder = struct - let label = Label.SessionReminder + let label = SessionReminder let email_params lang layout experiment session assignment = global_params layout assignment.Assignment.contact.Contact.user @@ -1135,7 +1131,7 @@ module SessionReminder = struct ] pool sys_langs - Label.SessionReminder + SessionReminder in let%lwt gtx_config = Gtx_config.find_exn pool in let layout = layout_from_tenant tenant in @@ -1161,7 +1157,7 @@ module SessionReminder = struct end module SessionReschedule = struct - let label = Label.SessionReschedule + let label = SessionReschedule let email_params lang layout experiment session new_start new_duration contact = let open Pool_model.Time in @@ -1198,7 +1194,7 @@ module SessionReschedule = struct end module SignUpVerification = struct - let label = Label.SignUpVerification + let label = SignUpVerification let email_params layout verification_url firstname lastname = let firstname = firstname |> Pool_user.Firstname.value in @@ -1259,7 +1255,7 @@ module SignUpVerification = struct end module UserImport = struct - let label = Label.UserImport + let label = UserImport let to_user = function | `Admin admin -> Admin.user admin @@ -1328,7 +1324,7 @@ module UserImport = struct end module WaitingListConfirmation = struct - let label = Label.WaitingListConfirmation + let label = WaitingListConfirmation let base_params layout contact = contact.Contact.user |> global_params layout let email_params layout contact experiment = diff --git a/pool/app/message_template/message_template.mli b/pool/app/message_template/message_template.mli index a4ddc637f..b27986792 100644 --- a/pool/app/message_template/message_template.mli +++ b/pool/app/message_template/message_template.mli @@ -4,47 +4,6 @@ module Id : sig val to_common : t -> Pool_common.Id.t end -module Label : sig - type t = - | AccountSuspensionNotification - | AssignmentCancellation - | AssignmentConfirmation - | AssignmentSessionChange - | ContactEmailChangeAttempt - | ContactRegistrationAttempt - | EmailVerification - | ExperimentInvitation - | InactiveContactWarning - | InactiveContactDeactivation - | Login2FAToken - | ManualSessionMessage - | MatcherNotification - | MatchFilterUpdateNotification - | PasswordChange - | PasswordReset - | PhoneVerification - | ProfileUpdateTrigger - | SignUpVerification - | SessionCancellation - | SessionReminder - | SessionReschedule - | UserImport - | WaitingListConfirmation - - val equal : t -> t -> bool - val pp : Format.formatter -> t -> unit - val show : t -> string - val t_of_yojson : Yojson.Safe.t -> t - val yojson_of_t : t -> Yojson.Safe.t - val read : string -> t - val read_from_url : string -> t - val of_string : string -> (t, Pool_message.Error.t) result - val to_human : t -> string - val human_url : t -> string - val prefixed_human_url : t -> string - val customizable_by_experiment : t list -end - module EmailSubject : sig include Pool_model.Base.StringSig end @@ -67,7 +26,7 @@ end type t = { id : Id.t - ; label : Label.t + ; label : Pool_common.MessageTemplateLabel.t ; entity_uuid : Pool_common.Id.t option ; language : Pool_common.Language.t ; email_subject : EmailSubject.t @@ -118,22 +77,26 @@ val find : Database.Label.t -> Id.t -> (t, Pool_message.Error.t) Lwt_result.t val find_default_by_label_and_language : Database.Label.t -> Pool_common.Language.t - -> Label.t + -> Pool_common.MessageTemplateLabel.t -> t Lwt.t -val find_default_by_label : Database.Label.t -> Label.t -> t list Lwt.t +val find_default_by_label + : Database.Label.t + -> Pool_common.MessageTemplateLabel.t + -> t list Lwt.t + val all_default : Database.Label.t -> unit -> t list Lwt.t val find_all_of_entity_by_label : Database.Label.t -> Pool_common.Id.t - -> Label.t + -> Pool_common.MessageTemplateLabel.t -> t list Lwt.t val find_by_label_and_language_to_send : Database.Label.t -> ?entity_uuids:Pool_common.Id.t list - -> Label.t + -> Pool_common.MessageTemplateLabel.t -> Pool_common.Language.t -> t Lwt.t @@ -141,14 +104,14 @@ val find_all_by_label_to_send : Database.Label.t -> ?entity_uuids:Pool_common.Id.t list -> Pool_common.Language.t list - -> Label.t + -> Pool_common.MessageTemplateLabel.t -> t list Lwt.t val find_entity_defaults_by_label : Database.Label.t -> ?entity_uuids:Pool_common.Id.t list -> Pool_common.Language.t list - -> Label.t + -> Pool_common.MessageTemplateLabel.t -> t list Lwt.t val filter_languages @@ -160,7 +123,7 @@ val filter_languages val missing_template_languages : Database.Label.t -> Pool_common.Id.t - -> Label.t + -> Pool_common.MessageTemplateLabel.t -> ?exclude:Pool_common.Language.t list -> Pool_common.Language.t list -> Pool_common.Language.t list Lwt.t @@ -210,7 +173,8 @@ type email_layout = } val layout_from_tenant : Pool_tenant.t -> email_layout -val template_hint : Label.t -> Pool_common.I18n.hint +val template_hint : Pool_common.MessageTemplateLabel.t -> Pool_common.I18n.hint +val customizable_label_by_experiment : Pool_common.MessageTemplateLabel.t list module History : sig val admin_item : Admin.t -> Pool_queue.History.item diff --git a/pool/app/message_template/repo/repo_entity.ml b/pool/app/message_template/repo/repo_entity.ml index 3340c8a59..116c0c998 100644 --- a/pool/app/message_template/repo/repo_entity.ml +++ b/pool/app/message_template/repo/repo_entity.ml @@ -15,12 +15,6 @@ module Id = struct ;; end -module Label = struct - include Label - - let t = Pool_common.Repo.make_caqti_type Caqti_type.string of_string show -end - module EmailSubject = struct include EmailSubject @@ -78,7 +72,7 @@ let t = (t2 Id.t (t2 - Label.t + Pool_common.Repo.MessageTemplateLabel.t (t2 (option Common.Id.t) (t2 diff --git a/pool/app/message_template/repo/repo_sql.ml b/pool/app/message_template/repo/repo_sql.ml index b3fe73eae..775a3f70d 100644 --- a/pool/app/message_template/repo/repo_sql.ml +++ b/pool/app/message_template/repo/repo_sql.ml @@ -1,7 +1,6 @@ module Dynparam = Database.Dynparam module RepoEntity = Repo_entity module Database = Database -open Entity let select_sql = {sql| @@ -100,14 +99,12 @@ let find_all_of_entity_by_label_request = AND pool_message_templates.label = $2 |} select_sql - |> Caqti_type.(t2 string string) ->* RepoEntity.t + |> Caqti_type.(t2 Pool_common.Repo.Id.t Pool_common.Repo.MessageTemplateLabel.t) + ->* RepoEntity.t ;; let find_all_of_entity_by_label pool entity_uuid label = - Database.collect - pool - find_all_of_entity_by_label_request - (Pool_common.Id.value entity_uuid, Label.show label) + Database.collect pool find_all_of_entity_by_label_request (entity_uuid, label) ;; let find_default_by_label_and_language_request = @@ -123,14 +120,12 @@ let find_default_by_label_and_language_request = pool_message_templates.entity_uuid IS NULL |sql} select_sql - |> Caqti_type.(t2 string string) ->! RepoEntity.t + |> Caqti_type.(t2 Pool_common.Repo.MessageTemplateLabel.t Pool_common.Repo.Language.t) + ->! RepoEntity.t ;; let find_default_by_label_and_language pool language label = - Database.find_opt - pool - find_default_by_label_and_language_request - (Entity.Label.show label, Pool_common.Language.show language) + Database.find_opt pool find_default_by_label_and_language_request (label, language) ;; let find_default_by_label_request = @@ -144,11 +139,11 @@ let find_default_by_label_request = pool_message_templates.entity_uuid IS NULL |sql} select_sql - |> Caqti_type.string ->! RepoEntity.t + |> Pool_common.Repo.MessageTemplateLabel.t ->! RepoEntity.t ;; let find_default_by_label pool label = - Database.collect pool find_default_by_label_request (Entity.Label.show label) + Database.collect pool find_default_by_label_request label ;; let find_by_label_and_language_to_send pool ?entity_uuids label language = @@ -156,8 +151,8 @@ let find_by_label_and_language_to_send pool ?entity_uuids label language = let dyn = Dynparam.( empty - |> add Caqti_type.string (Label.show label) - |> add Caqti_type.string (Pool_common.Language.show language)) + |> add Pool_common.Repo.MessageTemplateLabel.t label + |> add Pool_common.Repo.Language.t language) in let where = {sql| @@ -176,10 +171,7 @@ let find_by_label_and_language_to_send pool ?entity_uuids label language = ids |> CCList.foldi (fun (dyn, ids) i entity_uuid -> - let dyn = - Dynparam.( - dyn |> add Caqti_type.string (Pool_common.Id.value entity_uuid)) - in + let dyn = Dynparam.(dyn |> add Pool_common.Repo.Id.t entity_uuid) in let ids = ids @ [ Format.asprintf "UNHEX(REPLACE($%i, '-', ''))" (i + 3) ] in @@ -225,7 +217,7 @@ let find_all_by_label_to_send pool ?entity_uuids languages label = ||> CCOption.get_exn_or (Format.asprintf "Default message template %s (%s) is missing" - (Label.show label) + (Pool_common.MessageTemplateLabel.show label) (Pool_common.Language.show lang))) | Some entity_uuids -> languages diff --git a/pool/app/pool_common/dune b/pool/app/pool_common/dune index f491047a9..13699bce6 100644 --- a/pool/app/pool_common/dune +++ b/pool/app/pool_common/dune @@ -5,12 +5,12 @@ (preprocess (pps lwt_ppx - ppx_string ppx_deriving.enum ppx_deriving.eq ppx_deriving.ord ppx_deriving.show ppx_sexp_conv + ppx_string ppx_variants_conv ppx_yojson_conv))) diff --git a/pool/app/pool_common/entity.ml b/pool/app/pool_common/entity.ml index ca18ef196..e4f661585 100644 --- a/pool/app/pool_common/entity.ml +++ b/pool/app/pool_common/entity.ml @@ -299,3 +299,68 @@ module NotifyContact = struct let init = false let schema = schema Pool_message.Field.NotifyContact end + +module MessageTemplateLabel = struct + module Core = struct + let field = Pool_message.Field.MessageTemplate + + type t = + | AccountSuspensionNotification [@name "account_suspension_notification"] + [@printer print "account_suspension_notification"] + | AssignmentCancellation [@name "assignment_cancellation"] + [@printer print "assignment_cancellation"] + | AssignmentConfirmation [@name "assignment_confirmation"] + [@printer print "assignment_confirmation"] + | AssignmentSessionChange [@name "assignment_session_change"] + [@printer print "assignment_session_change"] + | ContactEmailChangeAttempt [@name "contact_email_change_attempt"] + [@printer print "contact_email_change_attempt"] + | ContactRegistrationAttempt [@name "contact_registration_attempt"] + [@printer print "contact_registration_attempt"] + | EmailVerification [@name "email_verification"] + [@printer print "email_verification"] + | ExperimentInvitation [@name "experiment_invitation"] + [@printer print "experiment_invitation"] + | InactiveContactWarning [@name "inactive_contact_warning"] + [@printer print "inactive_contact_warning"] + | InactiveContactDeactivation [@name "inactive_contact_deactivation"] + [@printer print "inactive_contact_deactivation"] + | Login2FAToken [@name "login_2fa_token"] [@printer print "login_2fa_token"] + | ManualSessionMessage [@name "manual_session_message"] + [@printer print "manual_session_message"] + | MatcherNotification [@name "matcher_notification"] + [@printer print "matcher_notification"] + | MatchFilterUpdateNotification [@name "match_filter_update_notification"] + [@printer print "match_filter_update_notification"] + | PasswordChange [@name "password_change"] [@printer print "password_change"] + | PasswordReset [@name "password_reset"] [@printer print "password_reset"] + | PhoneVerification [@name "phone_verification"] + [@printer print "phone_verification"] + | ProfileUpdateTrigger [@name "profile_update_trigger"] + [@printer print "profile_update_trigger"] + | SignUpVerification [@name "signup_verification"] + [@printer print "signup_verification"] + | SessionCancellation [@name "session_cancellation"] + [@printer print "session_cancellation"] + | SessionReminder [@name "session_reminder"] [@printer print "session_reminder"] + | SessionReschedule [@name "session_reschedule"] + [@printer print "session_reschedule"] + | UserImport [@name "user_import"] [@printer print "user_import"] + | WaitingListConfirmation [@name "waiting_list_confirmation"] + [@printer print "waiting_list_confirmation"] + [@@deriving enum, eq, ord, sexp_of, show { with_path = false }, yojson, variants] + end + + include Pool_model.Base.SelectorType (Core) + include Core + open CCFun.Infix + + let read_from_url = CCString.replace ~which:`All ~sub:"-" ~by:"_" %> read + let of_string = create + let to_human = show %> CCString.replace ~sub:"_" ~by:" " %> CCString.capitalize_ascii + let human_url = show %> CCString.replace ~sub:"_" ~by:"-" + + let prefixed_human_url = + human_url %> Format.asprintf "%s/%s" Pool_message.Field.(human_url MessageTemplate) + ;; +end diff --git a/pool/app/pool_common/entity_i18n.ml b/pool/app/pool_common/entity_i18n.ml index a35a5ee73..fa3fb538c 100644 --- a/pool/app/pool_common/entity_i18n.ml +++ b/pool/app/pool_common/entity_i18n.ml @@ -352,7 +352,9 @@ type hint = | SignUpForWaitingList | SmtpMissing | SmtpSettingsDefaultFlag + | SmtpSettingsInternalRegex | SmtpSettingsIntro + | SmtpSettingsSystemAccountFlag | SmtpValidation | SurveyUrl | SwapSessions diff --git a/pool/app/pool_common/locales/i18n_de.ml b/pool/app/pool_common/locales/i18n_de.ml index 822030b53..e4ce7edf6 100644 --- a/pool/app/pool_common/locales/i18n_de.ml +++ b/pool/app/pool_common/locales/i18n_de.ml @@ -750,10 +750,16 @@ Wenn keine der Checkboxen angewählt ist, bedeutet das, dass der Kontakt erschie | SmtpSettingsDefaultFlag -> "Achtung: Ist eine andere SMTP Konfiguration als Standard markiert, wird diese \ Einstellung angepasst. Nur eine Konfiguration kann als Standard markiert sein." + | SmtpSettingsInternalRegex -> + {|E-Mails, die auf diesen regulären Ausdruck passen, gelten als intern und werden über diesen SMTP-Server gesendet. Beispiel: Um alle UZH-Adressen zu erfassen, verwende "@uzh\.ch|@.*\.uzh\.ch".|} | SmtpSettingsIntro -> {|Die folgende Konfiguration wird vom E-Mail Service verwendet. Beachte: Bei Verwendung des Mechanismus für "LOGIN" muss ein Benutzername und Passwort angegeben werden.|} + | SmtpSettingsSystemAccountFlag -> + "Achtung: Wenn diese Einstellung aktiviert ist, wird diese SMTP Konfiguration für \ + systembezogene E-Mails verwendet, diese können über die Systemeinstellungen \ + konfiguriert werden." | SmtpValidation -> "Please provide an email address to which a test message can be sent to validate the \ SMTP settings." diff --git a/pool/app/pool_common/locales/i18n_en.ml b/pool/app/pool_common/locales/i18n_en.ml index ebfdf41b3..a8db1eb16 100644 --- a/pool/app/pool_common/locales/i18n_en.ml +++ b/pool/app/pool_common/locales/i18n_en.ml @@ -714,11 +714,16 @@ If you trigger the reminders manually now, no more automatic reminders will be s | SmtpSettingsDefaultFlag -> "Attention: If another SMTP configuration is marked as default, it will be \ overwritten. Only one configuration can be marked as default." + | SmtpSettingsInternalRegex -> + {|Emails matching this regex are considered internal and will be routed through this SMTP server. Example: to match all UZH addresses use "@uzh\.ch|@.*\.uzh\.ch".|} | SmtpSettingsIntro -> {|The following configuration is used by the email service. Note: When using the mechanism "LOGIN" a username and password are required. |} + | SmtpSettingsSystemAccountFlag -> + "Attention: If this setting is enabled, this SMTP configuration will be used for \ + system-related emails, which can be configured through the system settings." | SmtpValidation -> "Please provide an email address to which a test message can be sent to validate the \ SMTP settings." diff --git a/pool/app/pool_common/locales/locales_de.ml b/pool/app/pool_common/locales/locales_de.ml index 7bccba544..d99b10c4e 100644 --- a/pool/app/pool_common/locales/locales_de.ml +++ b/pool/app/pool_common/locales/locales_de.ml @@ -286,12 +286,16 @@ let rec field_to_string = | SMS -> "SMS" | SmsText -> "SMS Text" | Smtp -> "SMTP" + | SmtpInternalRegex -> "Interne Regex für E-Mail-Adressen" + | SmtpInvitationCapacity -> "Einladungskapazität (% des Limits)" | SmtpLabel -> "Label" | SmtpMechanism -> "Authentifizierungsmechanismus" | SmtpPassword -> "Passwort" | SmtpPort -> "Port" | SmtpProtocol -> "Protokoll" + | SmtpRateLimit -> "Rate (max. E-Mails/24h)" | SmtpServer -> "Server" + | SmtpSystemAccount -> "Systemaccount" | SmtpUsername -> "Benutzername" | SortOrder -> "Sortierung" | Start -> "Start" @@ -680,6 +684,10 @@ let rec error_to_string = | SmtpLoginMissingCredentials -> "Der SMTP-Authentifizierungsmechanismus kann nicht auf LOGIN gesetzt werden, wenn \ kein Benutzername oder Passwort festgelegt ist." + | SmtpRecipientNotFound recipient -> + Format.asprintf + "Der Empfänger der E-Mail konnte nicht gefunden werden (%s)." + recipient | TerminatoryTenantError | TerminatoryRootError -> "Bitte versuchen Sie es später erneut." | TerminatoryTenantErrorTitle | TerminatoryRootErrorTitle -> diff --git a/pool/app/pool_common/locales/locales_en.ml b/pool/app/pool_common/locales/locales_en.ml index 4732f4535..b8968e586 100644 --- a/pool/app/pool_common/locales/locales_en.ml +++ b/pool/app/pool_common/locales/locales_en.ml @@ -284,12 +284,16 @@ let rec field_to_string = | SMS -> "SMS" | SmsText -> "SMS text" | Smtp -> "smtp" + | SmtpInternalRegex -> "internal regex for email addresses" + | SmtpInvitationCapacity -> "invitation capacity (% of the rate limit)" | SmtpLabel -> "label" | SmtpMechanism -> "mechanism" | SmtpPassword -> "password" | SmtpPort -> "port" | SmtpProtocol -> "protocol" + | SmtpRateLimit -> "rate limit (emails/24h)" | SmtpServer -> "server" + | SmtpSystemAccount -> "system account" | SmtpUsername -> "username" | SortOrder -> "sort order" | Start -> "start" @@ -658,6 +662,8 @@ let rec error_to_string = | SmtpException exn -> exn | SmtpLoginMissingCredentials -> "SMTP auth mechanism cannot be set to LOGIN when no username or password is set." + | SmtpRecipientNotFound recipient -> + Format.asprintf "The recipient of the email could not be found (%s)." recipient | TerminatoryTenantError | TerminatoryRootError -> "Please try again later." | TerminatoryTenantErrorTitle | TerminatoryRootErrorTitle -> "An error occurred" | TermsAndConditionsMissing -> "Terms and conditions have to be added first." diff --git a/pool/app/pool_common/pool_common.mli b/pool/app/pool_common/pool_common.mli index 0ca4e97b1..3d03a1dd3 100644 --- a/pool/app/pool_common/pool_common.mli +++ b/pool/app/pool_common/pool_common.mli @@ -180,6 +180,49 @@ module NotifyContact : sig include Pool_model.Base.BooleanSig end +module MessageTemplateLabel : sig + type t = + | AccountSuspensionNotification + | AssignmentCancellation + | AssignmentConfirmation + | AssignmentSessionChange + | ContactEmailChangeAttempt + | ContactRegistrationAttempt + | EmailVerification + | ExperimentInvitation + | InactiveContactWarning + | InactiveContactDeactivation + | Login2FAToken + | ManualSessionMessage + | MatcherNotification + | MatchFilterUpdateNotification + | PasswordChange + | PasswordReset + | PhoneVerification + | ProfileUpdateTrigger + | SignUpVerification + | SessionCancellation + | SessionReminder + | SessionReschedule + | UserImport + | WaitingListConfirmation + + val equal : t -> t -> bool + val compare : t -> t -> int + val pp : Format.formatter -> t -> unit + val show : t -> string + val t_of_yojson : Yojson.Safe.t -> t + val yojson_of_t : t -> Yojson.Safe.t + val read : string -> t + val read_from_url : string -> t + val of_string : string -> (t, Pool_message.Error.t) result + val all : t list + val to_human : t -> string + val human_url : t -> string + val prefixed_human_url : t -> string + val schema : unit -> ('a, t) Pool_conformist.Field.t +end + module Repo : sig val make_caqti_type : 'a Caqti_type.t @@ -224,6 +267,9 @@ module Repo : sig module VerificationCode : Pool_model.Base.CaqtiSig with type t = VerificationCode.t module ExperimentType : Pool_model.Base.CaqtiSig with type t = ExperimentType.t + + module MessageTemplateLabel : + Pool_model.Base.CaqtiSig with type t = MessageTemplateLabel.t end module Utils : sig diff --git a/pool/app/pool_common/repo.ml b/pool/app/pool_common/repo.ml index 6eaff5558..479620e6c 100644 --- a/pool/app/pool_common/repo.ml +++ b/pool/app/pool_common/repo.ml @@ -115,3 +115,5 @@ module VerificationCode = struct let t = make_caqti_type Caqti_type.string CCFun.(of_string %> CCResult.return) value end + +module MessageTemplateLabel = Model.SelectorType (MessageTemplateLabel) diff --git a/pool/app/pool_database/migrations/migration_202603061300.ml b/pool/app/pool_database/migrations/migration_202603061300.ml new file mode 100644 index 000000000..39081c4a9 --- /dev/null +++ b/pool/app/pool_database/migrations/migration_202603061300.ml @@ -0,0 +1,22 @@ +let add_smtp_rate_limit_and_capacity = + Database.Migration.Step.create + ~label:"Add rate_limit and invitation_capacity to pool_smtp" + {sql| + ALTER TABLE pool_smtp + ADD COLUMN system_account boolean DEFAULT false + AFTER default_account, + ADD COLUMN internal_regex TEXT + COMMENT 'Optional regex pattern to match recipient emails for this SMTP account' + AFTER system_account, + ADD COLUMN rate_limit INT UNSIGNED NOT NULL DEFAULT 86400 + COMMENT 'Max emails per 24 hours for this SMTP account' + AFTER internal_regex, + ADD COLUMN invitation_capacity TINYINT(3) UNSIGNED NOT NULL DEFAULT 80 + COMMENT 'Percentage of rate_limit reserved for invitation emails (0-100)' + AFTER rate_limit + |sql} +;; + +let migration () = + Database.Migration.(empty "202603061300" |> add_step add_smtp_rate_limit_and_capacity) +;; diff --git a/pool/app/pool_database/migrations/migration_202603131200.ml b/pool/app/pool_database/migrations/migration_202603131200.ml new file mode 100644 index 000000000..d71257c4e --- /dev/null +++ b/pool/app/pool_database/migrations/migration_202603131200.ml @@ -0,0 +1,18 @@ +let insert_system_email_templates_setting = + Database.Migration.Step.create + ~label:"seed system_email_templates setting" + {sql| + INSERT INTO pool_system_settings (uuid, settings_key, value) VALUES + ( + UNHEX(REPLACE(UUID(), '-', '')), + '["system_email_templates"]', + '[["account_suspension_notification"],["contact_email_change_attempt"],["contact_registration_attempt"],["email_verification"],["inactive_contact_warning"],["inactive_contact_deactivation"],["login_2fa_token"],["matcher_notification"],["match_filter_update_notification"],["password_change"],["password_reset"],["phone_verification"],["profile_update_trigger"],["signup_verification"],["user_import"]]' + ) + ON DUPLICATE KEY UPDATE id = id; + |sql} +;; + +let migration () = + Database.Migration.( + empty "202603131200" |> add_step insert_system_email_templates_setting) +;; diff --git a/pool/app/pool_database/root.ml b/pool/app/pool_database/root.ml index 450cd87af..2db068635 100644 --- a/pool/app/pool_database/root.ml +++ b/pool/app/pool_database/root.ml @@ -31,6 +31,7 @@ let steps = ; Migration_202504141225.migration () ; Migration_202505121331.migration () ; Migration_202506261422.migration () + ; Migration_202603061300.migration () ] |> sort in diff --git a/pool/app/pool_database/tenant.ml b/pool/app/pool_database/tenant.ml index 91c797dbc..f3a63f046 100644 --- a/pool/app/pool_database/tenant.ml +++ b/pool/app/pool_database/tenant.ml @@ -88,6 +88,8 @@ let steps = ; Migration_202505121331.migration () ; Migration_202506261422.migration () ; Migration_202508141040.migration () + ; Migration_202603061300.migration () + ; Migration_202603131200.migration () ] |> sort in diff --git a/pool/app/settings/entity.ml b/pool/app/settings/entity.ml index 2d11da1ad..bdff96324 100644 --- a/pool/app/settings/entity.ml +++ b/pool/app/settings/entity.ml @@ -40,6 +40,8 @@ module Key = struct type t = | ContactEmail [@name "contact_email"] [@printer printer "contact_email"] | EmailSuffixes [@name "email_suffixes"] [@printer printer "email_suffixes"] + | SystemEmailTemplates [@name "system_email_templates"] + [@printer printer "system_email_templates"] | InactiveUserDisableAfter [@name "inactive_user_disable_after"] [@printer printer "inactive_user_disable_after"] | InactiveUserWarning [@name "inactive_user_warning"] @@ -96,6 +98,34 @@ module EmailSuffixes = struct let key = Key.EmailSuffixes end +module SystemEmailTemplates = struct + open Pool_common + open CCFun.Infix + + type t = MessageTemplateLabel.t list [@@deriving eq, show] + + let key = Key.SystemEmailTemplates + let normalize = CCList.sort_uniq ~cmp:MessageTemplateLabel.compare + + let yojson_of_t = + CCList.map MessageTemplateLabel.yojson_of_t %> fun values -> `List values + ;; + + let t_of_yojson = function + | `List values -> + values + |> CCList.filter_map (fun value -> + try Some (MessageTemplateLabel.t_of_yojson value) with + | _ -> None) + |> normalize + | _ -> [] + ;; + + let schema () : (Pool_conformist.error_msg, t) Pool_conformist.Field.t = + Pool_conformist.(list @@ MessageTemplateLabel.schema ()) + ;; +end + module EmailReminderLeadTime = struct type t = Pool_common.Reminder.EmailLeadTime.t [@@deriving eq, show, yojson] @@ -227,6 +257,7 @@ let action_of_param = function | "disable_inactive_user_service" -> Ok `UpdateUnactiveUserServiceDisabled | "update_contact_email" -> Ok `UpdateContactEmail | "update_emailsuffix" -> Ok `UpdateEmailSuffixes + | "update_system_email_templates" -> Ok `UpdateSystemEmailTemplates | "update_languages" -> Ok `UpdateLanguages | "update_trigger_profile_update_after" -> Ok `UpdateTriggerProfileUpdateAfter | "user_import_first_reminder_after" -> Ok `UserImportFirstReminderAfter @@ -245,6 +276,7 @@ let stringify_action = function | `UpdateUnactiveUserServiceDisabled -> "disable_inactive_user_service" | `UpdateContactEmail -> "update_contact_email" | `UpdateEmailSuffixes -> "update_emailsuffix" + | `UpdateSystemEmailTemplates -> "update_system_email_templates" | `UpdateLanguages -> "update_languages" | `UpdateTriggerProfileUpdateAfter -> "update_trigger_profile_update_after" | `UserImportFirstReminderAfter -> "user_import_first_reminder_after" diff --git a/pool/app/settings/event.ml b/pool/app/settings/event.ml index ae1b14908..f88e7d83f 100644 --- a/pool/app/settings/event.ml +++ b/pool/app/settings/event.ml @@ -6,6 +6,7 @@ type event = | DefaultReminderLeadTimeUpdated of Pool_common.Reminder.EmailLeadTime.t | DefaultTextMsgReminderLeadTimeUpdated of Pool_common.Reminder.TextMessageLeadTime.t | EmailSuffixesUpdated of EmailSuffixes.t + | SystemEmailTemplatesUpdated of SystemEmailTemplates.t | InactiveUserDisableAfterUpdated of InactiveUser.DisableAfter.t | InactiveUserWarningUpdated of InactiveUser.Warning.t | InactiveUserServiceDisabled of InactiveUser.ServiceDisabled.t @@ -20,6 +21,8 @@ let handle_event ?user_uuid pool : event -> unit Lwt.t = function | LanguagesUpdated languages -> Repo.TenantLanguages.update ?user_uuid pool languages | EmailSuffixesUpdated suffixes -> Repo.TenantEmailSuffixes.update ?user_uuid pool suffixes + | SystemEmailTemplatesUpdated templates -> + Repo.SystemEmailTemplates.update ?user_uuid pool templates | DefaultReminderLeadTimeUpdated lead_time -> Repo.DefaultReminderLeadTime.update ?user_uuid pool lead_time | DefaultTextMsgReminderLeadTimeUpdated lead_time -> diff --git a/pool/app/settings/repo/repo.ml b/pool/app/settings/repo/repo.ml index 645a7464c..993686265 100644 --- a/pool/app/settings/repo/repo.ml +++ b/pool/app/settings/repo/repo.ml @@ -4,7 +4,10 @@ module Database = Database let make_caqti ~encode ~decode = let encode = encode %> Yojson.Safe.to_string %> CCResult.return in - let decode = Yojson.Safe.from_string %> decode %> CCResult.return in + let decode value = + try Ok (value |> Yojson.Safe.from_string |> decode) with + | exn -> Error (Printexc.to_string exn) + in Caqti_type.(custom ~encode ~decode Caqti_type.string) ;; @@ -101,6 +104,7 @@ module DefaultReminderLeadTime = SettingRepo (EmailReminderLeadTime) module DefaultTextMsgReminderLeadTime = SettingRepo (TextMsgReminderLeadTime) module TenantLanguages = SettingRepo (TenantLanguages) module TenantEmailSuffixes = SettingRepo (EmailSuffixes) +module SystemEmailTemplates = SettingRepo (SystemEmailTemplates) module TenantContactEmail = SettingRepo (ContactEmail) module InactiveUserDisableAfter = SettingRepo (InactiveUser.DisableAfter) module InactiveUserWarning = SettingRepo (InactiveUser.Warning) @@ -223,7 +227,7 @@ module PageScripts = struct FROM pool_tenant_page_scripts WHERE location = ? - AND script IS NOT NULL + AND script IS NOT NULL |sql} |> Caqti_type.(string ->? string) ;; diff --git a/pool/app/settings/settings.ml b/pool/app/settings/settings.ml index 3a8bac7e4..6b3f3b3e3 100644 --- a/pool/app/settings/settings.ml +++ b/pool/app/settings/settings.ml @@ -4,6 +4,12 @@ module Guard = Entity_guard let find_languages = Repo.TenantLanguages.find let find_email_suffixes = Repo.TenantEmailSuffixes.find + +let find_system_email_templates database_label = + let open Utils.Lwt_result.Infix in + Repo.SystemEmailTemplates.find database_label ||> SystemEmailTemplates.normalize +;; + let find_contact_email = Repo.TenantContactEmail.find let find_inactive_user_disable_after = Repo.InactiveUserDisableAfter.find let find_inactive_user_warning = Repo.InactiveUserWarning.find diff --git a/pool/app/settings/settings.mli b/pool/app/settings/settings.mli index a8750abf1..c2c482931 100644 --- a/pool/app/settings/settings.mli +++ b/pool/app/settings/settings.mli @@ -15,6 +15,7 @@ module Key : sig type t = | ContactEmail | EmailSuffixes + | SystemEmailTemplates | InactiveUserDisableAfter | InactiveUserWarning | InactiveUserServiceDisabled @@ -38,6 +39,16 @@ module EmailSuffix : sig include Pool_model.Base.StringSig end +module SystemEmailTemplates : sig + type t = Pool_common.MessageTemplateLabel.t list + + val equal : t -> t -> bool + val pp : Format.formatter -> t -> unit + val show : t -> string + val normalize : t -> t + val schema : unit -> (Pool_conformist.error_msg, t) Pool_conformist.Field.t +end + module InactiveUser : sig module DisableAfter : sig include Pool_model.Base.DurationSig @@ -125,6 +136,7 @@ val action_of_param | `UpdateUnactiveUserServiceDisabled | `UpdateContactEmail | `UpdateEmailSuffixes + | `UpdateSystemEmailTemplates | `UpdateLanguages | `UpdateTriggerProfileUpdateAfter | `UserImportFirstReminderAfter @@ -144,6 +156,7 @@ val stringify_action | `UpdateUnactiveUserServiceDisabled | `UpdateContactEmail | `UpdateEmailSuffixes + | `UpdateSystemEmailTemplates | `UpdateLanguages | `UpdateTriggerProfileUpdateAfter | `UserImportFirstReminderAfter @@ -159,6 +172,7 @@ type event = | DefaultReminderLeadTimeUpdated of Pool_common.Reminder.EmailLeadTime.t | DefaultTextMsgReminderLeadTimeUpdated of Pool_common.Reminder.TextMessageLeadTime.t | EmailSuffixesUpdated of EmailSuffix.t list + | SystemEmailTemplatesUpdated of SystemEmailTemplates.t | InactiveUserDisableAfterUpdated of InactiveUser.DisableAfter.t | InactiveUserWarningUpdated of InactiveUser.Warning.t | InactiveUserServiceDisabled of InactiveUser.ServiceDisabled.t @@ -174,6 +188,7 @@ val pp_event : Format.formatter -> event -> unit val show_event : event -> string val find_languages : Database.Label.t -> Pool_common.Language.t list Lwt.t val find_email_suffixes : Database.Label.t -> EmailSuffix.t list Lwt.t +val find_system_email_templates : Database.Label.t -> SystemEmailTemplates.t Lwt.t val find_contact_email : Database.Label.t -> ContactEmail.t Lwt.t val find_inactive_user_disable_after diff --git a/pool/app/text_message/event.ml b/pool/app/text_message/event.ml index f0f57020d..c59652a28 100644 --- a/pool/app/text_message/event.ml +++ b/pool/app/text_message/event.ml @@ -1,10 +1,9 @@ -open Ppx_yojson_conv_lib.Yojson_conv.Primitives open Entity type job = { job : t ; id : Pool_queue.Id.t option [@yojson.option] - ; message_template : string option [@yojson.option] + ; message_template : Pool_common.MessageTemplateLabel.t option [@yojson.option] ; job_ctx : Pool_queue.job_ctx option [@yojson.option] } [@@deriving eq, fields, show, yojson] diff --git a/pool/app/text_message/text_message.mli b/pool/app/text_message/text_message.mli index 6f5a77691..de90807d1 100644 --- a/pool/app/text_message/text_message.mli +++ b/pool/app/text_message/text_message.mli @@ -47,7 +47,7 @@ module Service : sig val dispatch : ?id:Pool_queue.Id.t -> ?new_recipient:Pool_user.CellPhone.t - -> ?message_template:string + -> ?message_template:Pool_common.MessageTemplateLabel.t -> ?job_ctx:Pool_queue.job_ctx -> Database.Label.t -> t @@ -57,7 +57,7 @@ end type job = { job : t ; id : Pool_queue.Id.t option - ; message_template : string option + ; message_template : Pool_common.MessageTemplateLabel.t option ; job_ctx : Pool_queue.job_ctx option } @@ -67,12 +67,12 @@ val show_job : job -> string val yojson_of_job : job -> Yojson.Safe.t val job : job -> t val id : job -> Pool_queue.Id.t option -val message_template : job -> string option +val message_template : job -> Pool_common.MessageTemplateLabel.t option val job_ctx : job -> Pool_queue.job_ctx option val create_job : ?id:Pool_queue.Id.t - -> ?message_template:string + -> ?message_template:Pool_common.MessageTemplateLabel.t -> ?job_ctx:Pool_queue.job_ctx -> t -> job @@ -121,7 +121,7 @@ val handle_event : Database.Label.t -> event -> unit Lwt.t val create_sent : ?id:Pool_queue.Id.t - -> ?message_template:string + -> ?message_template:Pool_common.MessageTemplateLabel.t -> ?job_ctx:Pool_queue.job_ctx -> ?new_recipient:Pool_user.CellPhone.t -> t diff --git a/pool/app/utils/utils.ml b/pool/app/utils/utils.ml index 4bcce5e5e..9c4568acd 100644 --- a/pool/app/utils/utils.ml +++ b/pool/app/utils/utils.ml @@ -109,6 +109,26 @@ module Bool = struct let to_string = Bool.to_string end +module Lwt_cache = struct + let once r f = + match !r with + | Some v -> Lwt.return v + | None -> + let%lwt v = f () in + r := Some v; + Lwt.return v + ;; + + let cached tbl key f = + match Hashtbl.find_opt tbl key with + | Some v -> Lwt.return v + | None -> + let%lwt v = f () in + Hashtbl.replace tbl key v; + Lwt.return v + ;; +end + module Html = struct open Tyxml.Html diff --git a/pool/command/command_matcher.ml b/pool/command/command_matcher.ml index 377492799..f92f5a24c 100644 --- a/pool/command/command_matcher.ml +++ b/pool/command/command_matcher.ml @@ -5,7 +5,7 @@ let run_tenant = "matcher.run" "Run invitation matcher (Inverval: 5 minutes)" (fun pool -> - let%lwt () = Matcher.match_invitations interval [ pool ] in + let%lwt () = Matcher.match_invitations interval pool in Lwt.return_some ()) ;; @@ -16,6 +16,8 @@ let run_all = (fun () -> let open Database.Pool in let%lwt () = initialize () in - let%lwt () = Tenant.all () |> Matcher.match_invitations interval in + let%lwt () = + Tenant.all () |> Lwt_list.iter_s (Matcher.match_invitations interval) + in Lwt.return_some ()) ;; diff --git a/pool/cqrs_command/message_template_command.ml b/pool/cqrs_command/message_template_command.ml index 2e320653b..da812b20f 100644 --- a/pool/cqrs_command/message_template_command.ml +++ b/pool/cqrs_command/message_template_command.ml @@ -16,7 +16,7 @@ module Create : sig val handle : ?tags:Logs.Tag.set -> ?id:Message_template.Id.t - -> Message_template.Label.t + -> Pool_common.MessageTemplateLabel.t -> Pool_common.Id.t -> Pool_common.Language.t list -> t diff --git a/pool/cqrs_command/settings_command.ml b/pool/cqrs_command/settings_command.ml index 0f582c9de..1a6b12f8c 100644 --- a/pool/cqrs_command/settings_command.ml +++ b/pool/cqrs_command/settings_command.ml @@ -93,6 +93,33 @@ end = struct let effects = Settings.Guard.Access.update end +module UpdateSystemEmailTemplates : sig + include Common.CommandSig with type t = Pool_common.MessageTemplateLabel.t list + + val decode : (string * string list) list -> (t, Pool_message.Error.t) result +end = struct + type t = Pool_common.MessageTemplateLabel.t list + + let schema = + Conformist.(make Field.[ Settings.SystemEmailTemplates.schema () ] CCFun.id) + ;; + + let decode = + Conformist.decode_and_validate schema + %> CCResult.map_err Pool_message.to_conformist_error + ;; + + let handle ?(tags = Logs.Tag.empty) templates = + Logs.info ~src (fun m -> m "Handle command UpdateSystemEmailTemplates" ~tags); + Ok + [ SystemEmailTemplatesUpdated (SystemEmailTemplates.normalize templates) + |> Pool_event.settings + ] + ;; + + let effects = Settings.Guard.Access.update +end + module UpdateContactEmail : sig include Common.CommandSig with type t = Settings.ContactEmail.t diff --git a/pool/cqrs_command/smtp_command.ml b/pool/cqrs_command/smtp_command.ml index 5db048f0f..88f0ef748 100644 --- a/pool/cqrs_command/smtp_command.ml +++ b/pool/cqrs_command/smtp_command.ml @@ -17,6 +17,10 @@ type create = ; mechanism : SmtpAuth.Mechanism.t ; protocol : SmtpAuth.Protocol.t ; default : SmtpAuth.Default.t + ; system_account : SmtpAuth.SystemAccount.t + ; internal_regex : SmtpAuth.InternalRegex.t option + ; rate_limit : SmtpAuth.RateLimit.t + ; invitation_capacity : SmtpAuth.InvitationCapacity.t } type update = @@ -27,10 +31,37 @@ type update = ; mechanism : SmtpAuth.Mechanism.t ; protocol : SmtpAuth.Protocol.t ; default : SmtpAuth.Default.t + ; system_account : SmtpAuth.SystemAccount.t + ; internal_regex : SmtpAuth.InternalRegex.t option + ; rate_limit : SmtpAuth.RateLimit.t + ; invitation_capacity : SmtpAuth.InvitationCapacity.t } -let update_command label server port username mechanism protocol default = - { label; server; port; username; mechanism; protocol; default } +let update_command + label + server + port + username + mechanism + protocol + default + system_account + internal_regex + rate_limit + invitation_capacity + = + { label + ; server + ; port + ; username + ; mechanism + ; protocol + ; default + ; system_account + ; internal_regex + ; rate_limit + ; invitation_capacity + } ;; let update_schema = @@ -44,6 +75,10 @@ let update_schema = ; SmtpAuth.Mechanism.schema () ; SmtpAuth.Protocol.schema () ; SmtpAuth.Default.schema () + ; SmtpAuth.SystemAccount.schema () + ; Conformist.optional @@ SmtpAuth.InternalRegex.schema () + ; SmtpAuth.RateLimit.schema () + ; SmtpAuth.InvitationCapacity.schema () ] update_command) ;; @@ -67,8 +102,33 @@ module Create : sig end = struct type t = create - let command label server port username password mechanism protocol default = - { label; server; port; username; password; mechanism; protocol; default } + let command + label + server + port + username + password + mechanism + protocol + default + system_account + internal_regex + rate_limit + invitation_capacity + = + { label + ; server + ; port + ; username + ; password + ; mechanism + ; protocol + ; default + ; system_account + ; internal_regex + ; rate_limit + ; invitation_capacity + } ;; let schema = @@ -83,16 +143,36 @@ end = struct ; SmtpAuth.Mechanism.schema () ; SmtpAuth.Protocol.schema () ; SmtpAuth.Default.schema () + ; SmtpAuth.SystemAccount.schema () + ; Conformist.optional @@ SmtpAuth.InternalRegex.schema () + ; SmtpAuth.RateLimit.schema () + ; SmtpAuth.InvitationCapacity.schema () ] command) ;; let smtp_of_command ?id - { label; server; port; username; password; mechanism; protocol; default } + { label + ; server + ; port + ; username + ; password + ; mechanism + ; protocol + ; default + ; system_account + ; internal_regex + ; rate_limit + ; invitation_capacity + } = SmtpAuth.Write.create ?id + ~rate_limit + ~invitation_capacity + ~system_account + ?internal_regex label server port @@ -168,6 +248,10 @@ end = struct ; mechanism = command.mechanism ; protocol = command.protocol ; default + ; rate_limit = command.rate_limit + ; invitation_capacity = command.invitation_capacity + ; system_account = command.system_account + ; internal_regex = command.internal_regex } in Ok [ Email.SmtpEdited update |> Pool_event.email; clear_cache_event ~id:clear_id () ] diff --git a/pool/matcher/dune b/pool/matcher/dune index 30c7f6684..b95aa5e80 100644 --- a/pool/matcher/dune +++ b/pool/matcher/dune @@ -3,10 +3,11 @@ (libraries cqrs_command database + email experiment mailing pool_common schedule utils) (preprocess - (pps lwt_ppx))) + (pps lwt_ppx ppx_string))) diff --git a/pool/matcher/matcher.ml b/pool/matcher/matcher.ml index c5cdcf440..911e46789 100644 --- a/pool/matcher/matcher.ml +++ b/pool/matcher/matcher.ml @@ -4,34 +4,17 @@ open Utils.Lwt_result.Infix let src = Logs.Src.create "matcher.service" let tags = Database.(Logger.Tags.create Pool.Root.label) -type config = - { start : bool option - ; rate_limit : int - ; max_capacity : int - } -[@@warning "-69"] - -let config start rate_limit max_capacity = { start; rate_limit; max_capacity } - -type env = - | Run - | EmailRateLimit - | MaxCapacity +type env = Run let to_string = function | Run -> "MATCHER_RUN" - | EmailRateLimit -> "EMAIL_RATE_LIMIT" - | MaxCapacity -> "MATCHER_MAX_CAPACITY" ;; -let read_variable fcn env = - fcn (env |> to_string) +let read_bool env = + Sihl.Configuration.read_bool (env |> to_string) |> CCOption.get_exn_or (Format.asprintf "Variable not defined: %s" (env |> to_string)) ;; -let read_int = read_variable Sihl.Configuration.read_int -let read_bool = read_variable Sihl.Configuration.read_bool - let schema = let open Conformist in make @@ -41,18 +24,8 @@ let schema = ~meta:"If set to false, the matcher will not be executed." ~default:(Sihl.Configuration.is_production ()) (Run |> to_string)) - ; int - ~meta:"Rate limit of the mail server to external mail addresses" - ~validator:(fun m -> - if m >= 0 then None else Some "Rate limit cannot have a value below zero.") - (EmailRateLimit |> to_string) - ; int - ~meta:"maximum percentage of the rate limit used for invitations" - ~validator:(fun m -> - if m >= 0 && m <= 100 then None else Some "Not a percentage value.") - (MaxCapacity |> to_string) ] - config + CCFun.id ;; let get_or_failwith element = @@ -63,12 +36,6 @@ let get_or_failwith element = let sum = CCList.fold_left ( + ) 0 -let for_interval interval rate = - (* calculated number from the rate per hour to the specified interval *) - let rate = max rate 0. in - CCFloat.(rate / 3600. * (interval |> Ptime.Span.to_float_s)) -;; - let experiment_has_bookable_spots database_label { Experiment.id; online_experiment; _ } = let open Utils.Lwt_result.Infix in let open Session in @@ -111,37 +78,25 @@ let find_contacts_by_mailing pool { Mailing.id; distribution; _ } limit = (experiment, contacts, use_case) |> Lwt_result.return ;; -let calculate_mailing_limits - interval - (pool_based_mailings : ('a * Mailing.Status.status list) list) - = +let calculate_mailing_limits remaining_capacity statuses = + (* Distribute [remaining_capacity] across mailings proportionally to their + requested amounts (to_handle). If the total requested <= remaining_capacity + every mailing gets its full amount; otherwise each gets a proportional share. *) let open CCList in let open CCFloat in - let rate_limit = read_int EmailRateLimit |> CCInt.to_float in - let factor = read_int MaxCapacity |> CCInt.to_float in - let max_total_invitations = rate_limit * (factor / 100.) |> for_interval interval in let total = - let open Mailing.Status in - pool_based_mailings + statuses |> fold_left - (fun init (_, status) -> init :: (status >|= to_handle %> ToHandle.value) |> sum) - 0 - in - let reduce_factor = - (* only allow a factor between 0 and 1 *) - max_total_invitations / of_int total |> min 1. |> max 0. + (fun acc s -> acc +. (Mailing.Status.(to_handle s |> ToHandle.value) |> of_int)) + 0. in - pool_based_mailings - >|= fun (pool, mailing_status) -> - let limit_to_mailing = - mailing_status - >|= fun { Mailing.Status.mailing; to_handle; _ } -> - let open CCFloat in - let to_handle = Mailing.Status.ToHandle.value to_handle |> of_int in - let limit = to_handle *. reduce_factor |> floor |> to_int in - mailing, limit - in - pool, limit_to_mailing + let capacity = of_int remaining_capacity in + let reduce_factor = if total <= 0. then 0. else capacity /. total |> min 1. |> max 0. in + statuses + >|= fun { Mailing.Status.mailing; to_handle; _ } -> + let to_handle = Mailing.Status.ToHandle.value to_handle |> of_int in + let limit = to_handle *. reduce_factor |> floor |> to_int in + mailing, limit ;; let notify_all_invited pool tenant experiment = @@ -165,141 +120,195 @@ let notify_all_invited pool tenant experiment = Lwt.return (experiment_event :: email_event) ;; -let events_of_mailings ?invitation_ids = - let ok_or_log_error = function - | Ok (pool, events) when CCList.is_empty events -> - Logs.info ~src (fun m -> m ~tags:(Database.Logger.Tags.create pool) "No action"); - None - | Ok m -> Some m - | Error err -> - let open Pool_common in - let (_ : Pool_message.Error.t) = Utils.with_log_error ~tags err in - None +let events_of_mailings ?invitation_ids pool limited_mailings = + let tags = Database.Logger.Tags.create pool in + let open Lwt_result.Syntax in + let%lwt events = + let* tenant = Pool_tenant.find_by_label pool in + limited_mailings + |> Lwt_list.map_s (fun (mailing, limit) -> + find_contacts_by_mailing pool mailing limit + >>= fun (experiment, contacts, use_case) -> + match contacts with + | [] -> notify_all_invited pool tenant experiment |> Lwt_result.ok + | contacts -> + let open Cqrs_command.Invitation_command in + let contacts = sort_contacts contacts in + let%lwt create_message = + Message_template.ExperimentInvitation.prepare tenant experiment + in + let create_new contacts = + Create.( + handle + ?ids:invitation_ids + ~tags + { experiment + ; mailing = Some mailing + ; contacts + ; invited_contacts = [] + ; create_message + }) + in + let resend_existing invitations = + invitations + |> CCList.map (fun invitation -> + Resend.(handle ~tags ~mailing_id:mailing.Mailing.id create_message invitation)) + |> CCList.all_ok + |> CCResult.map CCList.flatten + in + (match use_case with + | Filter.MatchesFilter -> failwith "Invalid use case" + | Filter.Matcher _ -> + contacts + |> Lwt_list.fold_left_s + (fun (invitations, contacts) contact -> + Contact.id contact + |> Invitation.find_by_contact_and_experiment_opt + pool + experiment.Experiment.id + |> Lwt.map (function + | None -> invitations, contacts @ [ contact ] + | Some invitation -> invitations @ [ invitation ], contacts)) + ([], []) + >|> fun (invitations, contacts) -> + let* resend_events = resend_existing invitations |> Lwt_result.lift in + let* create_events = create_new contacts |> Lwt_result.lift in + Lwt_result.return (create_events @ resend_events))) + ||> CCList.all_ok + >|+ CCList.flatten in - Lwt_list.filter_map_s (fun (pool, limited_mailings) -> - let open Lwt_result.Syntax in - let%lwt events = - let* tenant = Pool_tenant.find_by_label pool in - limited_mailings - |> Lwt_list.map_s (fun (mailing, limit) -> - find_contacts_by_mailing pool mailing limit - >>= fun (experiment, contacts, use_case) -> - match contacts with - | [] -> notify_all_invited pool tenant experiment |> Lwt_result.ok - | contacts -> - let open Cqrs_command.Invitation_command in - let contacts = sort_contacts contacts in - let%lwt create_message = - Message_template.ExperimentInvitation.prepare tenant experiment - in - let create_new contacts = - Create.( - handle - ?ids:invitation_ids - ~tags - { experiment - ; mailing = Some mailing - ; contacts - ; invited_contacts = [] - ; create_message - }) - in - let resend_existing invitations = - invitations - |> CCList.map (fun invitation -> - Resend.( - handle ~tags ~mailing_id:mailing.Mailing.id create_message invitation)) - |> CCList.all_ok - |> CCResult.map CCList.flatten - in - (match use_case with - | Filter.MatchesFilter -> failwith "Invalid use case" - | Filter.Matcher _ -> - contacts - |> Lwt_list.fold_left_s - (fun (invitations, contacts) contact -> - Contact.id contact - |> Invitation.find_by_contact_and_experiment_opt - pool - experiment.Experiment.id - |> Lwt.map (function - | None -> invitations, contacts @ [ contact ] - | Some invitation -> invitations @ [ invitation ], contacts)) - ([], []) - >|> fun (invitations, contacts) -> - let* resend_events = resend_existing invitations |> Lwt_result.lift in - let* create_events = create_new contacts |> Lwt_result.lift in - Lwt_result.return (create_events @ resend_events))) - ||> CCList.all_ok - >|+ CCList.flatten - in - let open CCResult in - events >|= CCPair.make pool |> ok_or_log_error |> Lwt.return) + match events with + | Ok events when CCList.is_empty events -> + Logs.info ~src (fun m -> m ~tags "No action"); + Lwt.return [] + | Ok events -> Lwt.return events + | Error err -> + let open Pool_common in + let (_ : Pool_message.Error.t) = Utils.with_log_error ~tags err in + Lwt.return [] ;; -let create_invitation_events ?invitation_ids interval pools = - let%lwt pool_based_mailings = - Lwt_list.map_s - (fun pool -> - Mailing.Status.find_current pool interval - >|> Lwt_list.filter_map_s (fun ({ Mailing.Status.mailing; _ } as status) -> - let find_experiment { Mailing.id; _ } = - Experiment.find_of_mailing pool (id |> Mailing.Id.to_common) - in - let has_spots = experiment_has_bookable_spots pool in - let validate = function - | true -> Ok status - | false -> Error Pool_message.Error.SessionFullyBooked - in - mailing - |> find_experiment - |>> has_spots - >== validate - >|- Pool_common.Utils.with_log_error ~level:Logs.Warning - ||> CCResult.to_opt) - ||> fun m -> pool, m) - pools +let compute_limited_mailings pool interval = + let open Email.SmtpAuth in + let smtp_by_id : (Id.t, t option) Hashtbl.t = Hashtbl.create 4 in + let smtp_default : t option option ref = ref None in + let find_smtp_opt id = + Utils.Lwt_cache.cached smtp_by_id id (fun () -> find pool id ||> CCResult.to_opt) + in + let find_default_cached () = + Utils.Lwt_cache.once smtp_default (fun () -> find_default_opt pool) + in + let smtp_limits smtp_auth_id = + let default_limits = RateLimit.default, InvitationCapacity.default in + let limits smtp = rate_limit smtp, invitation_capacity smtp in + let find_or () = + find_default_cached () ||> CCOption.map_or ~default:default_limits limits + in + match smtp_auth_id with + | None -> find_or () + | Some id -> + (match%lwt find_smtp_opt id with + | Some smtp when Default.value (default smtp) -> find_or () + | Some smtp -> Lwt.return (limits smtp) + | None -> Lwt.return default_limits) + in + let%lwt status_with_smtp = + Mailing.Status.find_current pool interval + >|> Lwt_list.filter_map_s (fun ({ Mailing.Status.mailing; _ } as status) -> + let find_experiment { Mailing.id; _ } = + Experiment.find_of_mailing pool (id |> Mailing.Id.to_common) + in + let with_spots ({ Experiment.smtp_auth_id; _ } as experiment) = + match%lwt experiment_has_bookable_spots pool experiment with + | true -> Lwt.return_ok (status, smtp_auth_id) + | false -> Lwt.return_error Pool_message.Error.SessionFullyBooked + in + mailing + |> find_experiment + >>= with_spots + >|- Pool_common.Utils.with_log_error ~level:Logs.Warning + ||> CCResult.to_opt) in - pool_based_mailings - |> calculate_mailing_limits interval - |> events_of_mailings ?invitation_ids + (* Normalize: if smtp_auth_id points to the default account, treat it as None + so that mailings without a custom SMTP and those using the default are grouped together *) + let%lwt status_with_smtp = + status_with_smtp + |> Lwt_list.map_s (fun (status, smtp_auth_id) -> + match smtp_auth_id with + | None -> Lwt.return (status, None) + | Some id -> + find_smtp_opt id + ||> (function + | Some { default; _ } when Default.value default -> status, None + | Some _ | None -> status, smtp_auth_id)) + in + let groups = + let eq = CCOption.equal Id.equal in + CCList.fold_left + (fun acc (status, smtp_id) -> + let existing = CCList.Assoc.get ~eq smtp_id acc |> CCOption.get_or ~default:[] in + CCList.Assoc.set ~eq smtp_id (existing @ [ status ]) acc) + [] + status_with_smtp + in + groups + |> Lwt_list.map_s (fun (smtp_auth_id, statuses) -> + let%lwt rate_limit, invitation_capacity = smtp_limits smtp_auth_id in + let daily_cap = + let open CCFloat in + CCInt.to_float (RateLimit.value rate_limit) + *. (CCInt.to_float (InvitationCapacity.value invitation_capacity) /. 100.) + |> floor + |> to_int + in + let%lwt already_sent = + count_invitations_sent_since pool smtp_auth_id RateLimit.timediff_seconds + in + let remaining = max 0 (daily_cap - already_sent) in + Lwt.return (calculate_mailing_limits remaining statuses)) + ||> CCList.flatten ;; -let match_invitations interval pools = - let open Utils.Lwt_result.Infix in +let create_invitation_events ?invitation_ids interval database_label = + let%lwt limited_mailings = compute_limited_mailings database_label interval in + events_of_mailings ?invitation_ids database_label limited_mailings +;; + +let match_invitations interval database_label = let count_mails = CCList.filter_map (let open Pool_event in function[@warning "-4"] - (* TODO: Account based internal/external email count *) | Email (Email.Sent _) -> Some 1 | Email (Email.BulkSent mails) -> Some (CCList.length mails) | _ -> None) %> sum in - let handle_events = - Lwt_list.iter_s (fun (pool, events) -> - Logs.info ~src (fun m -> - m - ~tags:(Database.Logger.Tags.create pool) - "Sending %4d intivation emails" - (count_mails events)); - Pool_event.handle_system_events pool events) - in - create_invitation_events interval pools >|> handle_events + let%lwt events = create_invitation_events interval database_label in + Logs.info ~src (fun m -> + m + ~tags:(Database.Logger.Tags.create database_label) + "Sending %4d invitation emails" + (count_mails events)); + Pool_event.handle_system_events database_label events ;; let start_matcher () = let open Schedule in let interval = Ptime.Span.of_int_s (5 * 60) in - let periodic_fcn () = - Logs.debug ~src (fun m -> m ~tags:Database.(Logger.Tags.create Pool.Root.label) "Run"); - Database.(Pool.Tenant.all ()) |> match_invitations interval - in - let schedule = - create "matcher" (Every (interval |> ScheduledTimeSpan.of_span)) None periodic_fcn - in - Schedule.add_and_start schedule + Database.Pool.Tenant.all () + |> Lwt_list.iter_s (fun database_label -> + let label = [%string "matcher [%{Database.Label.value database_label}]"] in + Logs.debug ~src (fun m -> + m ~tags:(Database.Logger.Tags.create database_label) "Starting %s" label); + let schedule = + create + label + (Every (interval |> ScheduledTimeSpan.of_span)) + (Some database_label) + (fun () -> match_invitations interval database_label) + in + Schedule.add_and_start schedule) ;; let start () = diff --git a/pool/matcher/matcher.mli b/pool/matcher/matcher.mli index ad716aab3..44a106c17 100644 --- a/pool/matcher/matcher.mli +++ b/pool/matcher/matcher.mli @@ -11,15 +11,16 @@ val experiment_has_bookable_spots : Database.Label.t -> Experiment.t -> bool Lwt val events_of_mailings : ?invitation_ids:Pool_common.Id.t list - -> (Database.Label.t * (Mailing.t * int) list) list - -> (Database.Label.t, Pool_event.t list) CCPair.t list Lwt.t + -> Database.Label.t + -> (Mailing.t * int) list + -> Pool_event.t list Lwt.t val create_invitation_events : ?invitation_ids:Pool_common.Id.t list -> Ptime.Span.t - -> Database.Label.t list - -> (Database.Label.t * Pool_event.t list) list Lwt.t + -> Database.Label.t + -> Pool_event.t list Lwt.t -val match_invitations : Ptime.Span.t -> Database.Label.t list -> unit Lwt.t +val match_invitations : Ptime.Span.t -> Database.Label.t -> unit Lwt.t val lifecycle : Sihl.Container.lifecycle val register : unit -> Sihl.Container.Service.t diff --git a/pool/pool_message/field.ml b/pool/pool_message/field.ml index 9e7bd4114..0973ddc5a 100644 --- a/pool/pool_message/field.ml +++ b/pool/pool_message/field.ml @@ -312,12 +312,17 @@ type t = | SMS [@name "sms"] [@printer go "sms"] | SmsText [@name "sms_text"] [@printer go "sms_text"] | Smtp [@name "smtp"] [@printer go "smtp"] + | SmtpInternalRegex [@name "smtp_internal_regex"] [@printer go "smtp_internal_regex"] + | SmtpInvitationCapacity [@name "smtp_invitation_capacity"] + [@printer go "smtp_invitation_capacity"] | SmtpLabel [@name "smtp_label"] [@printer go "smtp_label"] | SmtpMechanism [@name "smtp_mechanism"] [@printer go "smtp_mechanism"] | SmtpPassword [@name "smtp_password"] [@printer go "smtp_password"] | SmtpPort [@name "smtp_port"] [@printer go "smtp_port"] | SmtpProtocol [@name "smtp_protocol"] [@printer go "smtp_protocol"] + | SmtpRateLimit [@name "smtp_rate_limit"] [@printer go "smtp_rate_limit"] | SmtpServer [@name "smtp_server"] [@printer go "smtp_server"] + | SmtpSystemAccount [@name "smtp_system_account"] [@printer go "smtp_system_account"] | SmtpUsername [@name "smtp_username"] [@printer go "smtp_username"] | SortOrder [@name "sort_order"] [@printer go "sort_order"] | Start [@name "start"] [@printer go "start"] diff --git a/pool/pool_message/field.mli b/pool/pool_message/field.mli index e0f3ea4a9..1b7578526 100644 --- a/pool/pool_message/field.mli +++ b/pool/pool_message/field.mli @@ -272,12 +272,16 @@ type t = | SMS | SmsText | Smtp + | SmtpInternalRegex + | SmtpInvitationCapacity | SmtpLabel | SmtpMechanism | SmtpPassword | SmtpPort | SmtpProtocol + | SmtpRateLimit | SmtpServer + | SmtpSystemAccount | SmtpUsername | SortOrder | Start @@ -573,12 +577,16 @@ val signupcount : t val sms : t val smstext : t val smtp : t +val smtpinternalregex : t +val smtpinvitationcapacity : t val smtplabel : t val smtpmechanism : t val smtppassword : t val smtpport : t val smtpprotocol : t +val smtpratelimit : t val smtpserver : t +val smtpsystemaccount : t val smtpusername : t val sortorder : t val start : t diff --git a/pool/pool_message/pool_message_error.ml b/pool/pool_message/pool_message_error.ml index b574fb4ee..a0ae50db4 100644 --- a/pool/pool_message/pool_message_error.ml +++ b/pool/pool_message/pool_message_error.ml @@ -129,6 +129,7 @@ type t = | Smaller of (Field.t * Field.t) | SmtpException of string | SmtpLoginMissingCredentials + | SmtpRecipientNotFound of string | TerminatoryRootError | TerminatoryRootErrorTitle | TerminatoryTenantError diff --git a/pool/pool_queue/entity.ml b/pool/pool_queue/entity.ml index 03540a8b0..4b1efea4c 100644 --- a/pool/pool_queue/entity.ml +++ b/pool/pool_queue/entity.ml @@ -78,7 +78,7 @@ module Instance = struct { id : Id.t ; name : JobName.t ; input : string - ; message_template : string option + ; message_template : Pool_common.MessageTemplateLabel.t option ; tries : int ; max_tries : int ; run_at : RunAt.t diff --git a/pool/pool_queue/pool_queue.ml b/pool/pool_queue/pool_queue.ml index ab13326a9..b6db8c480 100644 --- a/pool/pool_queue/pool_queue.ml +++ b/pool/pool_queue/pool_queue.ml @@ -179,11 +179,16 @@ let work_job job instance = if Instance.should_run ~is_polled:true instance then ( let fail = fail database_label (AnyJob.retry_delay job) instance in + let cancel = Instance.cancelled %> update_and_return database_label in let%lwt instance = Lwt.catch (fun () -> let%lwt instance = handle database_label instance in - match%lwt run_job ~tags job instance with + match%lwt[@warning "-4"] run_job ~tags job instance with + | Error (Pool_message.Error.SmtpRecipientNotFound _ as msg) -> + (* Recipient does not exist — cancelling immediately without retrying *) + let%lwt () = (AnyJob.failed job) database_label msg instance in + cancel instance | Error msg -> fail msg | Ok () -> success database_label instance) (Printexc.to_string %> Pool_message.Error.nothandled %> fail) diff --git a/pool/pool_queue/pool_queue.mli b/pool/pool_queue/pool_queue.mli index 3eb303c1d..b5e0563f0 100644 --- a/pool/pool_queue/pool_queue.mli +++ b/pool/pool_queue/pool_queue.mli @@ -54,7 +54,7 @@ module Instance : sig val max_tries : t -> int val run_at : t -> Ptime.t val clone_of : t -> Id.t option - val message_template : t -> string option + val message_template : t -> Pool_common.MessageTemplateLabel.t option val input : t -> string val name : t -> JobName.t val database_label : t -> Database.Label.t @@ -65,7 +65,7 @@ module Instance : sig val create : ?id:Id.t - -> ?message_template:string + -> ?message_template:Pool_common.MessageTemplateLabel.t -> ?tries:int -> ?max_tries:int -> ?status:Status.t @@ -117,7 +117,7 @@ module Job : sig val to_instance : ?id:Id.t - -> ?message_template:string + -> ?message_template:Pool_common.MessageTemplateLabel.t -> ?run_at:run_at -> ?clone_of:Id.t -> Database.Label.t @@ -205,7 +205,7 @@ val job_ctx_clone : Id.t -> job_ctx val dispatch : ?id:Id.t -> ?callback:(Instance.t -> unit Lwt.t) - -> ?message_template:string + -> ?message_template:Pool_common.MessageTemplateLabel.t -> ?job_ctx:job_ctx -> ?run_at:run_at -> Database.Label.t @@ -217,7 +217,7 @@ val dispatch_all : ?callback:(Instance.t -> unit Lwt.t) -> ?run_at:run_at -> Database.Label.t - -> (Id.t * 'a * string option * job_ctx) list + -> (Id.t * 'a * Pool_common.MessageTemplateLabel.t option * job_ctx) list -> 'a Job.t -> unit Lwt.t diff --git a/pool/pool_queue/repo_entity.ml b/pool/pool_queue/repo_entity.ml index b78a5bda6..ffa4f7a8a 100644 --- a/pool/pool_queue/repo_entity.ml +++ b/pool/pool_queue/repo_entity.ml @@ -107,7 +107,7 @@ module Instance = struct [ Id.t ; JobName.t ; string - ; option string + ; option Pool_common.Repo.MessageTemplateLabel.t ; int ; int ; RunAt.t diff --git a/pool/routes/routes.ml b/pool/routes/routes.ml index 513b0db1f..152034f97 100644 --- a/pool/routes/routes.ml +++ b/pool/routes/routes.ml @@ -263,7 +263,7 @@ module Admin = struct ] in let add_template_label label = - let open Message_template.Label in + let open Pool_common.MessageTemplateLabel in label |> human_url |> Format.asprintf "/%s" in let location = @@ -384,7 +384,7 @@ module Admin = struct let open Session in let specific = let message_templates = - let open Message_template.Label in + let open Pool_common.MessageTemplateLabel in let label_specific = label_specific_template edit_template update_template in [ choose ~scope:(add_template_label SessionReminder) diff --git a/pool/test/assignment_test.ml b/pool/test/assignment_test.ml index 2b7956f49..b15d385be 100644 --- a/pool/test/assignment_test.ml +++ b/pool/test/assignment_test.ml @@ -39,7 +39,7 @@ let confirmation_email experiment (session : Session.t) assignment = in Email.Service.Job.create ?smtp_auth_id:experiment.Experiment.smtp_auth_id email |> Email.create_dispatch - ~message_template:(Label.show label) + ~message_template:label ~job_ctx: Pool_queue.( job_ctx_create diff --git a/pool/test/contact_test.ml b/pool/test/contact_test.ml index 0a394723e..8e5cc900f 100644 --- a/pool/test/contact_test.ml +++ b/pool/test/contact_test.ml @@ -44,7 +44,7 @@ let confirmation_mail contact = |> Email.Service.Job.create |> Email.create_dispatch ~job_ctx:Pool_queue.(job_ctx_create JobHistory.[ contact_item contact ]) - ~message_template:(Message_template.Label.show label) + ~message_template:label ;; let sign_up_contact contact_info = @@ -111,7 +111,7 @@ let verification_email (email_address, _, _, _, _) = ; bcc = [] } |> Email.Service.Job.create - |> Email.create_dispatch ~message_template:(Message_template.Label.show label) + |> Email.create_dispatch ~message_template:label ;; let sign_up_not_allowed_suffix () = diff --git a/pool/test/integration.ml b/pool/test/integration.ml index a9a4099f4..ed64b50b1 100644 --- a/pool/test/integration.ml +++ b/pool/test/integration.ml @@ -151,6 +151,18 @@ let suite = ; ( "matcher" , Matcher_test. [ test_case "create invitations" `Slow create_invitations + ; test_case + "create invitations for different user types" + `Slow + create_invitations_for_different_user_types + ; test_case + "exclude paused and disabled/inactive contacts" + `Slow + create_invitations_exclude_paused_and_disabled_inactive + ; test_case + "exclude inactive-only contacts" + `Slow + create_invitations_exclude_inactive_only ; test_case "send invitations" `Slow send_invitations ; test_case "reset experiment invitations" `Slow reset_invitations ; test_case "matcher notifiaction" `Slow matcher_notification diff --git a/pool/test/matcher_test.ml b/pool/test/matcher_test.ml index 1d149281c..c2d1a0d87 100644 --- a/pool/test/matcher_test.ml +++ b/pool/test/matcher_test.ml @@ -165,10 +165,40 @@ let create_invitations_model () = ; invited_contacts = [] } |> handle ~ids - |> CCResult.map sort_events in - let expected = expected_events ~ids experiment (Some mailing) contacts create_message in - Test_utils.check_result expected events + let[@warning "-4"] created, emails, contacts = + match events with + | Ok + [ Pool_event.Invitation + (Invitation.Created ({ Invitation.mailing = Some _; _ } as created)) + ; Pool_event.Email (Email.BulkSent emails) + ; Pool_event.Contact contactOne + ; Pool_event.Contact contactTwo + ] -> created, emails, [ contactOne; contactTwo ] + | Ok _ -> failwith "Event mismatch" + | Error err -> failwith Pool_common.(Utils.error_to_string Language.En err) + in + let open Alcotest in + let () = + check + bool + "experiment id" + true + (Experiment.Id.equal + created.Invitation.experiment.Experiment.id + experiment.Experiment.id) + in + let () = + check + bool + "mailing id" + true + (Mailing.Id.equal + (CCOption.get_exn_or "Missing mailing" created.Invitation.mailing).Mailing.id + mailing.Mailing.id) + in + let () = check int "invitations" 2 (CCList.length created.Invitation.invitations) in + check int "emails" (CCList.length contacts) (CCList.length emails) ;; let create_invitations _ () = @@ -189,10 +219,7 @@ let create_invitations _ () = in Integration_utils.MailingRepo.create ~start:Start.StartNow ~distribution ~limit id in - let run_matcher () = - Matcher.create_invitation_events interval [ pool ] - ||> CCList.assoc ~eq:Database.Label.equal pool - in + let run_matcher () = Matcher.create_invitation_events interval pool in let%lwt current = Status.find_current pool interval in let () = Alcotest.(check int "count mailings" 1 (CCList.length current)) in let mailing = current |> CCList.hd |> fun { Status.mailing; _ } -> mailing in @@ -232,6 +259,175 @@ let create_invitations _ () = Lwt.return_unit ;; +let update_contact current_user update contact = + let updated = update contact in + let%lwt () = + Contact.Updated updated + |> Pool_event.contact + |> Pool_event.handle_event pool current_user + in + Lwt.return updated +;; + +let created_invitation_contact_ids events = + let[@warning "-4"] invitation_contact_ids = function + | Pool_event.Invitation (Invitation.Created created) -> + created.Invitation.invitations + |> CCList.map (fun invitation -> + invitation.Invitation.contact |> Contact.id |> Contact.Id.value) + |> CCOption.return + | _ -> None + in + events + |> CCList.filter_map invitation_contact_ids + |> CCList.flatten + |> CCList.sort CCString.compare +;; + +let create_invitations_for_different_user_types _ () = + let open MatcherTestUtils in + let%lwt current_user = current_user () in + let%lwt experiment, contacts = + setup_with_contacts + ~title_suffix:"create_invitations_different_user_types" + ~n_contacts:4 + current_user + in + let open_contact, pending_import_contact, paused_contact, disabled_inactive_contact = + match contacts with + | [ open_contact; pending_import_contact; paused_contact; disabled_inactive_contact ] + -> open_contact, pending_import_contact, paused_contact, disabled_inactive_contact + | _ -> failwith "Expected exactly 4 contacts" + in + let%lwt pending_import_contact = + update_contact + current_user + (fun contact -> + Contact.{ contact with import_pending = Pool_user.ImportPending.create true }) + pending_import_contact + in + let%lwt (_ : Contact.t) = + update_contact + current_user + (fun contact -> Contact.{ contact with paused = Pool_user.Paused.create true }) + paused_contact + in + let%lwt (_ : Contact.t) = + update_contact + current_user + (fun contact -> + Contact. + { contact with + disabled = Pool_user.Disabled.create true + ; user = Pool_user.{ contact.user with status = Status.Inactive } + }) + disabled_inactive_contact + in + let%lwt mailing = experiment |> Experiment.id |> MailingRepo.create in + let%lwt events = Matcher.events_of_mailings pool [ mailing, limit ] in + let expected_ids = + [ open_contact; pending_import_contact ] + |> CCList.map Contact.(id %> Id.value) + |> CCList.sort CCString.compare + in + let invitation_contact_ids = created_invitation_contact_ids events in + let () = + Alcotest.( + check + (list string) + "only open and pending import contacts receive invitations" + expected_ids + invitation_contact_ids) + in + let%lwt () = Mailing.Stopped mailing |> Mailing.handle_event pool in + Unix.sleep 1; + Lwt.return_unit +;; + +let create_invitations_exclude_paused_and_disabled_inactive _ () = + let open MatcherTestUtils in + let%lwt current_user = current_user () in + let%lwt experiment, contacts = + setup_with_contacts + ~title_suffix:"create_invitations_exclude_paused_and_disabled" + ~n_contacts:2 + current_user + in + let paused_contact, disabled_inactive_contact = + match contacts with + | [ paused_contact; disabled_inactive_contact ] -> + paused_contact, disabled_inactive_contact + | _ -> failwith "Expected exactly 2 contacts" + in + let%lwt (_ : Contact.t) = + update_contact + current_user + (fun contact -> Contact.{ contact with paused = Pool_user.Paused.create true }) + paused_contact + in + let%lwt (_ : Contact.t) = + update_contact + current_user + (fun contact -> + Contact. + { contact with + disabled = Pool_user.Disabled.create true + ; user = Pool_user.{ contact.user with status = Status.Inactive } + }) + disabled_inactive_contact + in + let%lwt mailing = experiment |> Experiment.id |> MailingRepo.create in + let%lwt events = Matcher.events_of_mailings pool [ mailing, limit ] in + let invitation_contact_ids = created_invitation_contact_ids events in + Alcotest.( + check + (list string) + "paused and disabled/inactive contacts do not receive invitations" + [] + invitation_contact_ids); + let%lwt () = Mailing.Stopped mailing |> Mailing.handle_event pool in + Unix.sleep 1; + Lwt.return_unit +;; + +let create_invitations_exclude_inactive_only _ () = + let open MatcherTestUtils in + let%lwt current_user = current_user () in + let%lwt experiment, contacts = + setup_with_contacts + ~title_suffix:"create_invitations_exclude_inactive_only" + ~n_contacts:1 + current_user + in + let inactive_contact = + match contacts with + | [ inactive_contact ] -> inactive_contact + | _ -> failwith "Expected exactly 1 contact" + in + let%lwt (_ : Contact.t) = + update_contact + current_user + (fun contact -> + Contact. + { contact with + user = Pool_user.{ contact.user with status = Status.Inactive } + }) + inactive_contact + in + let%lwt mailing = experiment |> Experiment.id |> MailingRepo.create in + let%lwt events = Matcher.events_of_mailings pool [ mailing, limit ] in + let invitation_contact_ids = created_invitation_contact_ids events in + Alcotest.( + check + (list string) + "inactive-only contacts do not receive invitations" + [] + invitation_contact_ids); + let%lwt () = Mailing.Stopped mailing |> Mailing.handle_event pool in + Unix.sleep 1; + Lwt.return_unit +;; + let expected_create_events ?(invitation_ids = []) contacts @@ -282,11 +478,7 @@ let send_invitations _ () = in let invitation_ids = CCList.map (fun _ -> Pool_common.Id.create ()) contacts in let%lwt mailing = experiment |> Experiment.id |> MailingRepo.create in - let%lwt events = - Matcher.events_of_mailings ~invitation_ids [ pool, [ mailing, limit ] ] - ||> CCList.hd - ||> snd - in + let%lwt events = Matcher.events_of_mailings ~invitation_ids pool [ mailing, limit ] in let%lwt expected = let%lwt create_email = invitation_mail tenant experiment in expected_create_events ~invitation_ids contacts mailing experiment create_email @@ -305,9 +497,7 @@ let reset_invitations _ () = in let%lwt () = Experiment.(handle_event pool (ResetInvitations experiment)) in let%lwt mailing = experiment |> Experiment.id |> MailingRepo.create in - let%lwt events = - Matcher.events_of_mailings [ pool, [ mailing, limit ] ] ||> CCList.hd ||> snd - in + let%lwt events = Matcher.events_of_mailings pool [ mailing, limit ] in let%lwt expected = let contacts = Matcher.sort_contacts contacts in let%lwt create_email = invitation_mail tenant experiment in @@ -341,8 +531,8 @@ let matcher_notification _ () = ||> Pool_event.email in let%lwt mailing = experiment |> Experiment.id |> MailingRepo.create in - let matcher_events () = Matcher.events_of_mailings [ pool, [ mailing, limit ] ] in - let%lwt events = matcher_events () ||> CCList.hd ||> snd in + let matcher_events () = Matcher.events_of_mailings pool [ mailing, limit ] in + let%lwt events = matcher_events () in let%lwt expected = let updated = Experiment. @@ -358,12 +548,7 @@ let matcher_notification _ () = let () = Alcotest.(check (list Test_utils.event) "succeeds" expected events) in let%lwt () = Pool_event.handle_events pool current_user events in (* Expect notification not to be sent again *) - let%lwt events = - matcher_events () - ||> function - | [] -> [] - | events -> events |> CCList.hd |> snd - in + let%lwt events = matcher_events () in let () = Alcotest.(check (list Test_utils.event) "succeeds" [] events) in Lwt.return_unit ;; @@ -389,12 +574,7 @@ let create_invitations_for_online_experiment _ () = in let run_test expected message = let%lwt events = - Matcher.create_invitation_events - ~invitation_ids - (Ptime.Span.of_int_s (5 * 60)) - [ pool ] - ||> CCList.assoc_opt ~eq:Database.Label.equal pool - ||> CCOption.value ~default:[] + Matcher.create_invitation_events ~invitation_ids (Ptime.Span.of_int_s (5 * 60)) pool in let%lwt expected = match expected with diff --git a/pool/test/message_mapping.ml b/pool/test/message_mapping.ml index 326b7a654..4d207ca2b 100644 --- a/pool/test/message_mapping.ml +++ b/pool/test/message_mapping.ml @@ -3,6 +3,7 @@ open Utils.Lwt_result.Infix open Integration_utils open Message_template open Pool_queue +open Pool_common.MessageTemplateLabel module JobHistory = Message_template.History let get_exn = Test_utils.get_or_failwith @@ -35,10 +36,8 @@ let check_text_message = let check_message_template ?label = let open Alcotest in - let valid_label = Message_template.Label.(Alcotest.testable pp equal) in - Email.message_template - %> CCOption.map (Message_template.Label.of_string %> Pool_common.Utils.get_or_failwith) - %> check (option valid_label) "correct message template" label + let valid_label = Pool_common.MessageTemplateLabel.(Alcotest.testable pp equal) in + Email.message_template %> check (option valid_label) "correct message template" label ;; let check_mapped_uuids expected = @@ -57,7 +56,7 @@ let account_suspension_notification _ () = let%lwt res = AccountSuspensionNotification.create tenant (Contact.user contact) ||> get_exn in - let () = check_message_template ~label:Label.AccountSuspensionNotification res in + let () = check_message_template ~label:AccountSuspensionNotification res in let () = check_mapped_uuids [ History.User, Contact.Id.to_common contact_id ] res in Lwt.return_unit ;; @@ -71,7 +70,7 @@ let assignment_confirmation _ () = AssignmentConfirmation.prepare tenant contact experiment session ||> fun create -> create assignment in - let () = check_message_template ~label:Label.AssignmentConfirmation res in + let () = check_message_template ~label:AssignmentConfirmation res in let () = check_mapped_uuids JobHistory. @@ -107,7 +106,7 @@ let assignment_session_change _ () = ; User, Contact.Id.to_common contact_id ] in - let () = check_message_template ~label:Label.AssignmentSessionChange res in + let () = check_message_template ~label:AssignmentSessionChange res in let () = check_mapped_uuids expected_uuids res in Lwt.return_unit ;; @@ -117,7 +116,7 @@ let contact_email_change_attempt _ () = let%lwt res = ContactEmailChangeAttempt.create tenant (Contact.user contact) ||> get_exn in - let () = check_message_template ~label:Label.ContactEmailChangeAttempt res in + let () = check_message_template ~label:ContactEmailChangeAttempt res in let () = check_mapped_uuids History.[ User, Contact.Id.to_common contact_id ] res in Lwt.return_unit ;; @@ -127,7 +126,7 @@ let contact_registration_attempt _ () = let%lwt res = ContactRegistrationAttempt.create language tenant (Contact.user contact) in - let () = check_message_template ~label:Label.ContactRegistrationAttempt res in + let () = check_message_template ~label:ContactRegistrationAttempt res in let () = check_mapped_uuids History.[ User, Contact.Id.to_common contact_id ] res in Lwt.return_unit ;; @@ -143,7 +142,7 @@ let email_verification _ () = ("new@email.com" |> Pool_user.EmailAddress.of_string) ("123123123" |> Pool_token.of_string) in - let expected = Label.EmailVerification, [ Contact.Id.to_common contact_id ] in + let expected = EmailVerification, [ Contact.Id.to_common contact_id ] in let () = check_message_template ~label:(fst expected) res in let () = check_mapped_uuids History.[ User, Contact.Id.to_common contact_id ] res in Lwt.return_unit @@ -154,7 +153,7 @@ let experiment_invitation _ () = let%lwt experiment = find_experiment () in let invitation = Invitation.create contact in let%lwt res = ExperimentInvitation.create tenant experiment invitation in - let () = check_message_template ~label:Label.ExperimentInvitation res in + let () = check_message_template ~label:ExperimentInvitation res in let () = check_mapped_uuids History. @@ -170,7 +169,7 @@ let experiment_invitation _ () = let password_change _ () = let%lwt contact = find_contact () in let%lwt res = PasswordChange.create language tenant (Contact.user contact) in - let () = check_message_template ~label:Label.PasswordChange res in + let () = check_message_template ~label:PasswordChange res in let () = check_mapped_uuids [ History.User, Contact.Id.to_common contact_id ] res in Lwt.return_unit ;; @@ -181,7 +180,7 @@ let password_reset _ () = PasswordReset.create database_label language (Tenant tenant) (Contact.user contact) ||> get_exn in - let () = check_message_template ~label:Label.PasswordReset res in + let () = check_message_template ~label:PasswordReset res in let () = check_mapped_uuids [ History.User, Contact.Id.to_common contact_id ] res in Lwt.return_unit ;; @@ -202,7 +201,7 @@ let phone_verification _ () = in let expected = Text_message.create_job - ~message_template:Label.(show PhoneVerification) + ~message_template:PhoneVerification ~job_ctx:(job_ctx_create [ History.User, Contact.Id.to_common contact_id ]) (res |> Text_message.job) in @@ -228,7 +227,7 @@ let session_reminder _ () = session ||> fun msg -> msg assignment cell_phone |> get_exn in - let expected_label = Label.SessionReminder in + let expected_label = SessionReminder in let expected_uuids = History. [ Experiment, Experiment.Id.to_common experiment_id @@ -238,7 +237,7 @@ let session_reminder _ () = in let expected = Text_message.create_job - ~message_template:Label.(show expected_label) + ~message_template:expected_label ~job_ctx:(job_ctx_create expected_uuids) (text_msg_res |> Text_message.job) in diff --git a/pool/test/message_template_test.ml b/pool/test/message_template_test.ml index 30cf3d0c8..f4a267cad 100644 --- a/pool/test/message_template_test.ml +++ b/pool/test/message_template_test.ml @@ -15,7 +15,7 @@ module Data = struct ] ;; - let label = Message_template.Label.ExperimentInvitation + let label = Pool_common.MessageTemplateLabel.ExperimentInvitation let create ?entity_uuid id = let open TemplateCommand.Create in @@ -95,7 +95,7 @@ let create_experiment () = let create_invitation language ?entity_uuid () = let database_label = Test_utils.Data.database_label in - let label = Message_template.Label.ExperimentInvitation in + let label = Data.label in let template = Test_utils.Model.create_message_template ~label ~language ?entity_uuid () in @@ -111,7 +111,7 @@ module LanguageTestsData = struct open Message_template let database_label = Test_utils.Data.database_label - let invitation_label = Label.ExperimentInvitation + let invitation_label = Data.label let create_experiment ?language () = { (Test_utils.Model.create_experiment ()) with Experiment.language } @@ -215,7 +215,6 @@ let get_template_with_experiment_language_and_template _ () = let get_template_with_language_missing _ () = let%lwt () = let database_label = Test_utils.Data.database_label in - let label = Message_template.Label.ExperimentInvitation in let%lwt experiment = create_experiment () in let template_language = Pool_common.Language.En in let%lwt template = @@ -230,7 +229,7 @@ let get_template_with_language_missing _ () = (Message_template.find_by_label_and_language_to_send database_label ~entity_uuids:Experiment.[ experiment.id |> Id.to_common ] - label) + Data.label) in (* When one entity specific template exists, expect this to be returned every time *) let expected = [ template; template ] in @@ -243,7 +242,6 @@ let get_template_with_language_missing _ () = let get_templates_in_multile_languages _ () = let%lwt () = let database_label = Test_utils.Data.database_label in - let label = Message_template.Label.ExperimentInvitation in let%lwt experiment = create_experiment () in let languages = Pool_common.Language.[ De; En ] in let%lwt templates = @@ -257,7 +255,7 @@ let get_templates_in_multile_languages _ () = (Message_template.find_by_label_and_language_to_send database_label ~entity_uuids:Experiment.[ experiment.id |> Id.to_common ] - label) + Data.label) in (* Expect all created templates to be returned *) Alcotest.(check (list Test_utils.message_template) "succeeds" templates res) diff --git a/pool/test/smtp_test.ml b/pool/test/smtp_test.ml index 614ee9cc0..a2038ef3e 100644 --- a/pool/test/smtp_test.ml +++ b/pool/test/smtp_test.ml @@ -12,6 +12,9 @@ module Data = struct let mechanism = Mechanism.LOGIN let protocol = Protocol.STARTTLS let default = Default.create true + let system_account = SystemAccount.create false + let rate_limit = Email.SmtpAuth.RateLimit.default + let invitation_capacity = Email.SmtpAuth.InvitationCapacity.default let write = Email.SmtpAuth.Write. @@ -24,6 +27,10 @@ module Data = struct ; mechanism ; protocol ; default + ; system_account + ; internal_regex = None + ; rate_limit + ; invitation_capacity } ;; @@ -38,6 +45,9 @@ module Data = struct let mechanism = Mechanism.show mechanism let protocol = Protocol.show protocol let default = Default.value default + let system_account = SystemAccount.value system_account + let rate_limit = Email.SmtpAuth.RateLimit.value rate_limit + let invitation_capacity = Email.SmtpAuth.InvitationCapacity.value invitation_capacity let valid = [ Field.(show SmtpLabel), [ label ] @@ -48,6 +58,9 @@ module Data = struct ; Field.(show SmtpMechanism), [ mechanism ] ; Field.(show SmtpProtocol), [ protocol ] ; Field.(show DefaultSmtpServer), [ Utils.Bool.to_string default ] + ; Field.(show SmtpSystemAccount), [ Utils.Bool.to_string system_account ] + ; Field.(show SmtpRateLimit), [ CCInt.to_string rate_limit ] + ; Field.(show SmtpInvitationCapacity), [ CCInt.to_string invitation_capacity ] ] ;; @@ -59,6 +72,9 @@ module Data = struct ; Field.(show SmtpMechanism), [ mechanism ] ; Field.(show SmtpProtocol), [ protocol ] ; Field.(show DefaultSmtpServer), [ Utils.Bool.to_string default ] + ; Field.(show SmtpSystemAccount), [ Utils.Bool.to_string system_account ] + ; Field.(show SmtpRateLimit), [ CCInt.to_string rate_limit ] + ; Field.(show SmtpInvitationCapacity), [ CCInt.to_string invitation_capacity ] ] ;; end @@ -67,23 +83,45 @@ end let create_smtp_valid () = let open Data in let open CCResult.Infix in - let event_id = System_event.Id.create () in + let open Email.SmtpAuth in let events = - Command.Create.( - Urlencoded.valid |> decode >>= smtp_of_command ~id:smtp_id >>= handle ~event_id None) + let open Command.Create in + let event_id = System_event.Id.create () in + Urlencoded.valid |> decode >>= smtp_of_command ~id:smtp_id >>= handle ~event_id None in - let expected = - Ok - [ Email.SmtpCreated write |> Pool_event.email - ; System_event.( - Job.SmtpAccountUpdated - |> create ~id:event_id - |> created - |> Pool_event.system_event) - ] + let[@warning "-4"] smtp_created = + match events with + | Ok Pool_event.[ Email (Email.SmtpCreated smtp); SystemEvent _ ] -> smtp + | Ok _ -> failwith "Unexpected event shape" + | Error err -> + let msg = Pool_common.(Utils.error_to_string Language.En err) in + failwith msg + in + let () = + Alcotest.(check bool "smtp id" true (Id.equal smtp_id smtp_created.Write.id)) + in + let () = + Alcotest.( + check + string + "smtp label" + (Label.value write.Write.label) + (Label.value smtp_created.Write.label)) + in + let () = + Alcotest.( + check + int + "rate limit" + (RateLimit.value write.Write.rate_limit) + (RateLimit.value smtp_created.Write.rate_limit)) in Alcotest.( - check (result (list Test_utils.event) Test_utils.error) "succeeds" expected events) + check + int + "invitation capacity" + (InvitationCapacity.value write.Write.invitation_capacity) + (InvitationCapacity.value smtp_created.Write.invitation_capacity)) ;; let create_missing_username () = diff --git a/pool/test/statistics_test.ml b/pool/test/statistics_test.ml index 14f18b919..28347034d 100644 --- a/pool/test/statistics_test.ml +++ b/pool/test/statistics_test.ml @@ -43,9 +43,8 @@ let invitation_statistics _ () = in let invite_contacts n = let%lwt mailing = MailingRepo.create experiment.id in - Matcher.events_of_mailings [ pool, [ mailing, n ] ] - ||> CCList.hd - >|> fun (pool, events) -> Pool_event.handle_events pool current_user events + Matcher.events_of_mailings pool [ mailing, n ] + >|> Pool_event.handle_events pool current_user in let check_invitations msg expected = let%lwt result = diff --git a/pool/test/tenant_test.ml b/pool/test/tenant_test.ml index 7a22b224c..93ecbdcfe 100644 --- a/pool/test/tenant_test.ml +++ b/pool/test/tenant_test.ml @@ -73,39 +73,51 @@ module Data = struct ;; module Smtp = struct - let id = SmtpAuth.Id.create () - let server = "smtp.uzh.ch" - let port = 587 - let username = "engineering@econ.uzh.ch" - let password = "emailemail" - let mechanism = SmtpAuth.Mechanism.(LOGIN, LOGIN |> show) - let protocol = SmtpAuth.Protocol.(STARTTLS, STARTTLS |> show) + module Raw = struct + let id = SmtpAuth.Id.create () + let server = "smtp.uzh.ch" + let port = 587 + let username = "engineering@econ.uzh.ch" + let password = "emailemail" + let mechanism = SmtpAuth.Mechanism.(LOGIN, LOGIN |> show) + let protocol = SmtpAuth.Protocol.(STARTTLS, STARTTLS |> show) + let system_account = false + let rate_limit = Email.SmtpAuth.RateLimit.default |> Email.SmtpAuth.RateLimit.value + + let invitation_capacity = + Email.SmtpAuth.InvitationCapacity.default + |> Email.SmtpAuth.InvitationCapacity.value + ;; + end let urlencoded ?(default = true) () = [ Field.SmtpLabel, [ database_label ] - ; Field.SmtpServer, [ server ] - ; Field.SmtpPort, [ port |> CCInt.to_string ] - ; Field.SmtpUsername, [ username ] - ; Field.SmtpPassword, [ password ] - ; Field.SmtpMechanism, [ snd mechanism ] - ; Field.SmtpProtocol, [ snd protocol ] + ; Field.SmtpServer, [ Raw.server ] + ; Field.SmtpPort, [ Raw.port |> CCInt.to_string ] + ; Field.SmtpUsername, [ Raw.username ] + ; Field.SmtpPassword, [ Raw.password ] + ; Field.SmtpMechanism, [ snd Raw.mechanism ] + ; Field.SmtpProtocol, [ snd Raw.protocol ] ; Field.DefaultSmtpServer, [ Utils.Bool.to_string default ] + ; Field.SmtpSystemAccount, [ Utils.Bool.to_string Raw.system_account ] + ; Field.SmtpRateLimit, [ CCInt.to_string Raw.rate_limit ] + ; Field.SmtpInvitationCapacity, [ CCInt.to_string Raw.invitation_capacity ] ] |> CCList.map (CCPair.map_fst Field.show) ;; let create () = - let new_id = id in + let new_id = Raw.id in let open CCResult in let open Email.SmtpAuth in let auth = let* label = database_label |> Label.create in - let* server = server |> Server.create in - let* port = port |> Port.create in - let* username = username |> Username.create |> CCResult.map CCOption.pure in - let* password = password |> Password.create |> CCResult.map CCOption.pure in - let mechanism = fst mechanism in - let protocol = fst protocol in + let* server = Raw.server |> Server.create in + let* port = Raw.port |> Port.create in + let* username = Raw.username |> Username.create |> CCResult.map CCOption.pure in + let* password = Raw.password |> Password.create |> CCResult.map CCOption.pure in + let mechanism = fst Raw.mechanism in + let protocol = fst Raw.protocol in let default = Default.create true in Write.create ~id:new_id @@ -130,10 +142,24 @@ module Data = struct ; mechanism ; protocol ; default + ; system_account + ; internal_regex ; _ } = - { SmtpAuth.id; label; server; port; username; mechanism; protocol; default } + { SmtpAuth.id + ; label + ; server + ; port + ; username + ; mechanism + ; protocol + ; default + ; system_account + ; internal_regex + ; rate_limit = Email.SmtpAuth.RateLimit.default + ; invitation_capacity = Email.SmtpAuth.InvitationCapacity.default + } ;; end @@ -226,7 +252,7 @@ let create_smtp_auth () = let open CCResult in let open Cqrs_command.Smtp_command.Create in decode (Data.Smtp.urlencoded ()) - >>= smtp_of_command ~id:Data.Smtp.id + >>= smtp_of_command ~id:Data.Smtp.Raw.id >>= handle ~event_id:sys_event_id None in let expected = @@ -247,7 +273,7 @@ let create_smtp_force_defaut () = let open CCResult in let open Cqrs_command.Smtp_command.Create in decode (Data.Smtp.urlencoded ~default:false ()) - >>= smtp_of_command ~id:Data.Smtp.id + >>= smtp_of_command ~id:Data.Smtp.Raw.id >>= handle ~event_id:sys_event_id None in let expected = diff --git a/pool/test/test_utils.ml b/pool/test/test_utils.ml index e6a536eb5..b9fb2ad8d 100644 --- a/pool/test/test_utils.ml +++ b/pool/test/test_utils.ml @@ -532,7 +532,11 @@ module Model = struct let create_message_template ?label ?language ?entity_uuid () = let open Message_template in let exn = CCResult.get_exn in - let label = CCOption.value ~default:Label.AssignmentConfirmation label in + let label = + CCOption.value + ~default:Pool_common.MessageTemplateLabel.AssignmentConfirmation + label + in let language = CCOption.value ~default:Pool_common.Language.En language in { id = Id.create () ; label diff --git a/pool/web/handler/admin_experiments.ml b/pool/web/handler/admin_experiments.ml index 15842a640..372c08ec1 100644 --- a/pool/web/handler/admin_experiments.ml +++ b/pool/web/handler/admin_experiments.ml @@ -95,7 +95,7 @@ let experiment_message_templates database_label experiment = Pool_common.Language.equal language experiment_language)) ||> CCPair.make label in - Label.customizable_by_experiment |> Lwt_list.map_s find_templates + customizable_label_by_experiment |> Lwt_list.map_s find_templates ;; let index req = @@ -377,8 +377,9 @@ let delete req = (`Experimenter, Some (Guard.Uuid.target_of Experiment.Id.value experiment_id)) in let%lwt templates = + let open Pool_common.MessageTemplateLabel in let open Message_template in - Label.[ ExperimentInvitation; SessionReminder; AssignmentConfirmation ] + [ ExperimentInvitation; SessionReminder; AssignmentConfirmation ] |> Lwt_list.map_s (find_all_of_entity_by_label database_label diff --git a/pool/web/handler/admin_experiments_assignments.ml b/pool/web/handler/admin_experiments_assignments.ml index 9aba994d4..5fba74ee6 100644 --- a/pool/web/handler/admin_experiments_assignments.ml +++ b/pool/web/handler/admin_experiments_assignments.ml @@ -426,7 +426,7 @@ let swap_session_get_helper action req = [ Session.Id.to_common session_id; Experiment.Id.to_common experiment_id ] database_label [ template_lang ] - Label.AssignmentSessionChange) + Pool_common.MessageTemplateLabel.AssignmentSessionChange) ||> CCList.head_opt ||> CCOption.to_result (Error.NotFound Field.Template) in diff --git a/pool/web/handler/admin_experiments_message_templates.ml b/pool/web/handler/admin_experiments_message_templates.ml index 2769ea1b4..53a6ff268 100644 --- a/pool/web/handler/admin_experiments_message_templates.ml +++ b/pool/web/handler/admin_experiments_message_templates.ml @@ -20,7 +20,7 @@ let experiment_path experiment_id = ;; type form_context = - | New of Message_template.Label.t + | New of Pool_common.MessageTemplateLabel.t | Edit of Message_template.Id.t let form form_context req = diff --git a/pool/web/handler/admin_message_templates.ml b/pool/web/handler/admin_message_templates.ml index 739c353f1..e4916ed1d 100644 --- a/pool/web/handler/admin_message_templates.ml +++ b/pool/web/handler/admin_message_templates.ml @@ -8,11 +8,12 @@ let create_layout req = General.create_tenant_layout req let template_id = HttpUtils.find_id Message_template.Id.of_string Field.MessageTemplate let template_label req = - let open Message_template.Label in + let open Pool_common.MessageTemplateLabel in try Ok (HttpUtils.find_id read_from_url Field.Label req - |> fun label -> CCList.find (equal label) customizable_by_experiment) + |> fun label -> + CCList.find (equal label) Message_template.customizable_label_by_experiment) with | _ -> Error Pool_message.(Error.Invalid Field.Label) ;; @@ -57,7 +58,7 @@ type redirect = } type action = - | Create of Pool_common.Id.t * Message_template.Label.t * redirect + | Create of Pool_common.Id.t * Pool_common.MessageTemplateLabel.t * redirect | Update of Message_template.Id.t * redirect let write action req = diff --git a/pool/web/handler/admin_session.ml b/pool/web/handler/admin_session.ml index 0b64839f1..6c00b2230 100644 --- a/pool/web/handler/admin_session.ml +++ b/pool/web/handler/admin_session.ml @@ -1,5 +1,6 @@ open CCFun open Pool_message +open Pool_common.MessageTemplateLabel open Utils.Lwt_result.Infix module HttpUtils = Http_utils module Message = HttpUtils.Message @@ -410,7 +411,7 @@ let show req = Message_template.find_all_of_entity_by_label database_label (session_id |> Session.Id.to_common) - Message_template.Label.SessionReminder + Pool_common.MessageTemplateLabel.SessionReminder in let sys_languages = Pool_context.Tenant.get_tenant_languages_exn req in let%lwt send_direct_message = @@ -699,7 +700,7 @@ let delete req = find_all_of_entity_by_label database_label (session_id |> Session.Id.to_common) - Label.SessionReminder + SessionReminder in let* events = let open Cqrs_command.Session_command.Delete in @@ -855,25 +856,22 @@ let message_template_form ?template_id label req = Response.handle ~src req result ;; -let new_session_reminder req = - message_template_form Message_template.Label.SessionReminder req -;; +let new_session_reminder req = message_template_form SessionReminder req let new_session_reminder_post req = let open Admin_message_templates in let experiment_id = experiment_id req in let session_id = session_id req in let entity_id = session_id |> Session.Id.to_common in - let label = Message_template.Label.SessionReminder in let redirect = { success = session_path ~id:session_id experiment_id; error = new_session_reminder } in - (write (Create (entity_id, label, redirect))) req + (write (Create (entity_id, SessionReminder, redirect))) req ;; let edit_template req = let template_id = template_id req in - message_template_form ~template_id Message_template.Label.SessionReminder req + message_template_form ~template_id SessionReminder req ;; let update_template req = @@ -894,12 +892,11 @@ let message_template_changelog req = let experiment_id = experiment_id req in let session_id = session_id req in let id = template_id req in - let label = Message_template.Label.SessionReminder in let url = HttpUtils.Url.Admin.session_message_template_path experiment_id session_id - label + SessionReminder ~suffix:"changelog" ~id () @@ -1006,10 +1003,7 @@ module DirectMessage = struct |> CCOption.value ~default:(CCList.hd system_languages) in Message_template.( - find_by_label_and_language_to_send - database_label - Label.ManualSessionMessage - language) + find_by_label_and_language_to_send database_label ManualSessionMessage language) in Page.Admin.Assignment.Partials.direct_message_modal context diff --git a/pool/web/handler/admin_settings.ml b/pool/web/handler/admin_settings.ml index e0bd09eb6..ba69c4c74 100644 --- a/pool/web/handler/admin_settings.ml +++ b/pool/web/handler/admin_settings.ml @@ -26,6 +26,9 @@ let settings_page ?open_tab req = in let languages = Pool_context.Tenant.get_tenant_languages_exn req in let%lwt email_suffixes = Settings.find_email_suffixes database_label in + let%lwt system_email_templates = + Settings.find_system_email_templates database_label + in let%lwt contact_email = Settings.find_contact_email database_label in let%lwt inactive_user_disable_after = Settings.find_inactive_user_disable_after database_label @@ -55,6 +58,7 @@ let settings_page ?open_tab req = ?open_tab languages email_suffixes + system_email_templates contact_email inactive_user_disable_after inactive_user_warning @@ -97,6 +101,10 @@ let update_settings req = let command_handler urlencoded = let open CCResult.Infix in function + | `UpdateSystemEmailTemplates -> + UpdateSystemEmailTemplates.( + urlencoded |> HttpUtils.combine_urlencoded_arrays |> decode >>= handle ~tags) + |> lift | `UpdateLanguages -> CCList.filter_map (fun (k, _) -> @@ -253,6 +261,7 @@ module Access : module type of Helpers.Access = struct | `UpdateUnactiveUserServiceDisabled -> Command.InactiveUser.DisableService.effects | `UpdateContactEmail -> Command.UpdateContactEmail.effects | `UpdateEmailSuffixes -> Command.UpdateEmailSuffixes.effects + | `UpdateSystemEmailTemplates -> Command.UpdateSystemEmailTemplates.effects | `UpdateLanguages -> Command.UpdateLanguages.effects | `UpdateTriggerProfileUpdateAfter -> Command.UpdateTriggerProfileUpdateAfter.effects diff --git a/pool/web/utils/http_utils.ml b/pool/web/utils/http_utils.ml index d72103530..1e25ec247 100644 --- a/pool/web/utils/http_utils.ml +++ b/pool/web/utils/http_utils.ml @@ -99,7 +99,16 @@ let find_query_param req field decode = let find_referer req = let open CCOption.Infix in - Httpaf.Headers.get req.Opium.Request.headers "referer" >|= Uri.of_string >|= Uri.path + let strip_prefix path = + let pre = + Sihl.Configuration.read_string "PREFIX_PATH" |> CCOption.value ~default:"" + in + CCString.chop_prefix ~pre path |> CCOption.value ~default:path + in + Httpaf.Headers.get req.Opium.Request.headers "referer" + >|= Uri.of_string + >|= Uri.path + >|= strip_prefix ;; let redirect_to_with_actions ?(skip_externalize = false) path actions = @@ -241,6 +250,17 @@ let multipart_to_urlencoded ingnore_fields lst = lst ;; +let combine_urlencoded_arrays urlencoded = + let tbl = Hashtbl.create 16 in + CCList.iter + (fun (key, value) -> + let key' = CCString.replace ~sub:"[]" ~by:"" ~which:`Right key in + let existing = CCOption.value (Hashtbl.find_opt tbl key') ~default:[] in + Hashtbl.replace tbl key' (existing @ value)) + urlencoded; + Hashtbl.to_seq tbl |> CCList.of_seq +;; + let placeholder_from_name = CCString.replace ~which:`All ~sub:"_" ~by:" " let is_req_from_root_host req = diff --git a/pool/web/utils/http_utils_url.ml b/pool/web/utils/http_utils_url.ml index 467d3485c..ca86ca2fb 100644 --- a/pool/web/utils/http_utils_url.ml +++ b/pool/web/utils/http_utils_url.ml @@ -24,7 +24,7 @@ module Admin = struct let settings_path = Format.asprintf "%s/%s" settings_base_path let settings_path_with_action action = - action |> Settings.stringify_action |> settings_path + action |> Settings.stringify_action |> settings_path |> Sihl.Web.externalize_path ;; let settings_path_with_action_param action = @@ -139,7 +139,7 @@ module Admin = struct "%s/%s/%s" (experiment_path ~id:experiment_id ()) Field.(human_url MessageTemplate) - (Message_template.Label.show label) + (Pool_common.MessageTemplateLabel.show label) |> append_opt (map Message_template.Id.value id) |> append_opt suffix ;; @@ -198,7 +198,7 @@ module Admin = struct "%s/%s/%s" (session_path ~id:session_id experiment_id) Field.(human_url MessageTemplate) - (Message_template.Label.show label) + (Pool_common.MessageTemplateLabel.show label) |> append_opt (map Message_template.Id.value id) |> append_opt suffix ;; diff --git a/pool/web/view/component/button.ml b/pool/web/view/component/button.ml index 8f9bc00f8..2b33e01cb 100644 --- a/pool/web/view/component/button.ml +++ b/pool/web/view/component/button.ml @@ -1,9 +1,8 @@ open Tyxml.Html let add ?(is_text = false) label path = - let open Message_template in let classnames = [ "btn"; "primary" ] @ if is_text then [ "is-text" ] else [] in a ~a:[ a_class classnames; a_href (Sihl.Web.externalize_path path) ] - [ txt (Format.asprintf "Add %s" (Label.to_human label)) ] + [ txt (Format.asprintf "Add %s" (Pool_common.MessageTemplateLabel.to_human label)) ] ;; diff --git a/pool/web/view/component/component_input.ml b/pool/web/view/component/component_input.ml index 8c847b4b1..a6769a6c4 100644 --- a/pool/web/view/component/component_input.ml +++ b/pool/web/view/component/component_input.ml @@ -716,24 +716,13 @@ type 'a multi_select = ; to_value : 'a -> string } -let multi_select - language - { options; selected; to_label; to_value } - group_field - ?(classnames = []) - ?(disabled = false) - ?(orientation = `Horizontal) - ?(required = false) +let multi_select_options ?additional_attributes - ?append_html - ?error + ?(disabled = false) ?flash_values - ?hints - ?label_field - () + { options; selected; to_label; to_value } + group_field = - let error = Elements.error language error in - let help_html = Elements.hints ~classnames:[ "flex-basis-100" ] language hints in CCList.map (fun option -> let value = to_value option in @@ -765,6 +754,32 @@ let multi_select let label = label ~a:[ a_label_for value ] [ txt (option |> to_label) ] in div [ input_elm; label ]) options +;; + +let multi_select + language + { options; selected; to_label; to_value } + group_field + ?(classnames = []) + ?(disabled = false) + ?(orientation = `Horizontal) + ?(required = false) + ?additional_attributes + ?append_html + ?error + ?flash_values + ?hints + ?label_field + () + = + let error = Elements.error language error in + let help_html = Elements.hints ~classnames:[ "flex-basis-100" ] language hints in + multi_select_options + ?additional_attributes + ~disabled + ?flash_values + { options; selected; to_label; to_value } + group_field |> fun inputs -> let classnames = if CCOption.(is_some append_html || is_some hints) diff --git a/pool/web/view/component/component_message_text_elements.ml b/pool/web/view/component/component_message_text_elements.ml index 1a6a5d457..2b3e407cc 100644 --- a/pool/web/view/component/component_message_text_elements.ml +++ b/pool/web/view/component/component_message_text_elements.ml @@ -2,7 +2,7 @@ open Tyxml.Html module DummyData = Component_message_text_elements_data let message_template_hints = - let open Message_template.Label in + let open Pool_common.MessageTemplateLabel in let open Pool_common.I18n in function | ExperimentInvitation -> @@ -101,7 +101,7 @@ let message_template_help template_label = let open Message_template in - let open Label in + let open Pool_common.MessageTemplateLabel in let open DummyData in let token = "123456789" in let open CCOption in diff --git a/pool/web/view/page/page_admin_assignments.ml b/pool/web/view/page/page_admin_assignments.ml index b52a12f87..68916d200 100644 --- a/pool/web/view/page/page_admin_assignments.ml +++ b/pool/web/view/page/page_admin_assignments.ml @@ -248,7 +248,7 @@ module Partials = struct ~text_messages_enabled context (`Create swap_session_template) - Message_template.Label.AssignmentSessionChange + Pool_common.MessageTemplateLabel.AssignmentSessionChange ~languages ?fixed_language:experiment.Experiment.language ~selected_language:swap_session_template.Message_template.language @@ -475,7 +475,7 @@ module Partials = struct ~text_messages_enabled:true context (`Create message_template) - Message_template.Label.AssignmentSessionChange + MessageTemplateLabel.AssignmentSessionChange ~languages ?fixed_language:experiment.Experiment.language ?selected_language diff --git a/pool/web/view/page/page_admin_experiments.ml b/pool/web/view/page/page_admin_experiments.ml index 6490b3da2..613612823 100644 --- a/pool/web/view/page/page_admin_experiments.ml +++ b/pool/web/view/page/page_admin_experiments.ml @@ -32,7 +32,6 @@ let notifications = let open CCList in let open Pool_common in - let open Message_template in match experiment.Experiment.language with | Some _ -> txt "" | None -> @@ -43,7 +42,9 @@ let notifications else filter (fun lang -> - find_opt (fun { language; _ } -> Language.equal language lang) templates + find_opt + (fun { Message_template.language; _ } -> Language.equal language lang) + templates |> CCOption.is_none) sys_languages |> function @@ -57,18 +58,14 @@ let notifications |> CCList.map (fun (label, languages) -> Format.asprintf "%s: [%s]" - (Label.to_human label) - (CCString.concat ", " (CCList.map Pool_common.Language.show languages)) + (MessageTemplateLabel.to_human label) + (CCString.concat ", " (CCList.map Language.show languages)) |> txt |> CCList.pure |> li) |> ul in - [ p - [ txt Pool_common.(Utils.hint_to_string language I18n.MissingMessageTemplates) - ] - ; list - ] + [ p [ txt (Utils.hint_to_string language I18n.MissingMessageTemplates) ]; list ] |> Notification.create language `Warning) ;; @@ -77,9 +74,11 @@ let message_template_buttons { Experiment.id; language; _ } message_templates = - let open Message_template in let build_button label = - experiment_path ~suffix:Label.(prefixed_human_url label) ~id () + experiment_path + ~suffix:Pool_common.MessageTemplateLabel.(prefixed_human_url label) + ~id + () |> Button.add ~is_text:true label in let exclude = @@ -89,7 +88,8 @@ let message_template_buttons in message_templates |> CCList.filter_map (fun (label, templates) -> - if CCList.is_empty (filter_languages ?exclude sys_languages templates) + if + CCList.is_empty (Message_template.filter_languages ?exclude sys_languages templates) then None else label |> build_button |> CCOption.pure) |> fun buttons -> @@ -1031,13 +1031,14 @@ let message_template_form form_context = let open Message_template in + let open Pool_common.MessageTemplateLabel in let open Pool_common in let control_to_title control = Layout.Experiment.Text (Format.asprintf "%s %s" (control |> Utils.control_to_string language) - (label |> Label.to_human |> CCString.lowercase_ascii)) + (label |> to_human |> CCString.lowercase_ascii)) in let control = match form_context with @@ -1047,7 +1048,7 @@ let message_template_form let action = let path suffix = experiment_path ~id ~suffix () in match form_context with - | `Create t -> path (Label.prefixed_human_url t.label) + | `Create t -> path (prefixed_human_url t.label) | `Update t -> path (prefixed_template_url t) in let text_elements = diff --git a/pool/web/view/page/page_admin_message_template.ml b/pool/web/view/page/page_admin_message_template.ml index f3776d2d6..19d382b30 100644 --- a/pool/web/view/page/page_admin_message_template.ml +++ b/pool/web/view/page/page_admin_message_template.ml @@ -19,7 +19,7 @@ let entity_hx_vals = function let template_label_url label suffix = Format.asprintf "/admin/message-template/%s/%s" - (Message_template.Label.show label) + (Pool_common.MessageTemplateLabel.show label) suffix |> Sihl.Web.externalize_path ;; @@ -415,13 +415,12 @@ let preview_template_modal language (label, templates) = Component.Modal.create ~active:true language - (fun _ -> Label.to_human label) + (fun _ -> Pool_common.MessageTemplateLabel.to_human label) preview_modal_id html ;; let experiment_help ~entity language labels = - let open Message_template in let modal = div ~a:[ a_id preview_modal_id ] [] in let help_text = p @@ -442,7 +441,9 @@ let experiment_help ~entity language labels = ; hx_swap "outerHTML" ; make_hx_vals hx_vals ] - [ txt (Label.to_human label); Icon.(to_html OpenOutline) ] + [ txt (Pool_common.MessageTemplateLabel.to_human label) + ; Icon.(to_html OpenOutline) + ] ] in labels |> CCList.map list_item |> ul ~a:[ a_class [ "inset"; "left"; "gap" ] ] diff --git a/pool/web/view/page/page_admin_queue.ml b/pool/web/view/page/page_admin_queue.ml index c7abf37be..6f583b73b 100644 --- a/pool/web/view/page/page_admin_queue.ml +++ b/pool/web/view/page/page_admin_queue.ml @@ -57,7 +57,10 @@ let list Pool_context.{ language; _ } queue_table url (queued_jobs, query) = [ txt (instance |> name), Some Field.Name ; ( txt (instance |> Instance.status |> Status.show |> CCString.capitalize_ascii) , Some Field.Status ) - ; ( txt (instance |> Instance.message_template |> CCOption.value ~default:"") + ; ( txt + (instance + |> Instance.message_template + |> CCOption.map_or Pool_common.MessageTemplateLabel.to_human ~default:"") , Some Field.MessageTemplate ) ; txt recipient, Some Field.Recipient ; ( instance diff --git a/pool/web/view/page/page_admin_session.ml b/pool/web/view/page/page_admin_session.ml index 82b7ea1fd..d545cd237 100644 --- a/pool/web/view/page/page_admin_session.ml +++ b/pool/web/view/page/page_admin_session.ml @@ -1103,7 +1103,7 @@ let detail div ~a:[ a_class [ "stack" ] ] [ table; links ] in let message_templates_html label list = - let open Message_template in + let open Pool_common.MessageTemplateLabel in let build_path append template = Format.asprintf "%s/%s" @@ -1116,13 +1116,11 @@ let detail if CCList.is_empty (Message_template.filter_languages sys_languages list) then None else ( - let path = - Format.asprintf "%s/%s" session_path Label.(prefixed_human_url label) - in + let path = Format.asprintf "%s/%s" session_path (prefixed_human_url label) in Some (Button.add label path)) in div - [ h2 ~a:[ a_class [ "heading-2"; "has-gap" ] ] [ txt (Label.to_human label) ] + [ h2 ~a:[ a_class [ "heading-2"; "has-gap" ] ] [ txt (to_human label) ] ; Page_admin_message_template.( experiment_help ~entity:(Session session.id) language [ label ]) ; div @@ -1309,7 +1307,7 @@ let detail ; session_overview ; tags_html ; message_templates_html - Message_template.Label.SessionReminder + MessageTemplateLabel.SessionReminder session_reminder_templates ; assignments_html ; Component.Changelog.list context changelog_url None @@ -1972,12 +1970,13 @@ let message_template_form = let open Message_template in let open Pool_common in + let open MessageTemplateLabel in let control_to_title control = Layout.Experiment.Text (Format.asprintf "%s %s" (control |> Utils.control_to_string language) - (label |> Label.to_human |> CCString.lowercase_ascii)) + (label |> to_human |> CCString.lowercase_ascii)) in let control = match form_context with @@ -1992,7 +1991,7 @@ let message_template_form Session.(Id.value session.Session.id) in match form_context with - | `Create t -> path (Label.prefixed_human_url t.label) + | `Create t -> path (prefixed_human_url t.label) | `Update t -> path (prefixed_template_url t) in let text_elements = diff --git a/pool/web/view/page/page_admin_settings.ml b/pool/web/view/page/page_admin_settings.ml index dd4996e12..503b143a8 100644 --- a/pool/web/view/page/page_admin_settings.ml +++ b/pool/web/view/page/page_admin_settings.ml @@ -82,6 +82,7 @@ let show ?open_tab tenant_languages email_suffixes + system_email_templates contact_email inactive_user_disable_after inactive_user_warning @@ -96,9 +97,9 @@ let show text_messages_enabled = let open Pool_common in - let submit ?(control = Message.(Control.Update None)) () = + let submit ?(classnames = [ "flexrow" ]) ?(control = Message.(Control.Update None)) () = div - ~a:[ a_class [ "flexrow" ] ] + ~a:[ a_class classnames ] [ submit_element ~classnames:[ "push"; "small" ] language control () ] in let open_changelog url = @@ -132,11 +133,18 @@ let show ] in let make_columns ?hint columns = - div - ~a:[ a_class [ "stack" ] ] - [ hint |> CCOption.map_or ~default:(txt "") (fun hint -> p [ txt hint ]) - ; div ~a:[ a_class [ "grid-col-2"; "flex-gap" ] ] columns - ] + let classnames = + if CCList.length columns > 1 then [ "grid-col-2"; "flex-gap" ] else [] + in + let hint_paragraph = + CCOption.map_or ~default:[] (fun hint -> [ p [ txt hint ] ]) hint + in + let with_columns = + if CCList.length columns > 1 + then [ div ~a:[ a_class classnames ] columns ] + else columns + in + div ~a:[ a_class [ "stack" ] ] (hint_paragraph @ with_columns) in let languages_html = let all_languages = @@ -257,6 +265,34 @@ let show in "Contact Email", [ form ], Some hint, [ `UpdateContactEmail ] in + let system_email_templates_html = + let open Pool_common.MessageTemplateLabel in + let form = + div + [ form + ~a:(form_attrs `UpdateSystemEmailTemplates) + [ csrf_element csrf () + ; div + ~a:[ a_class [ "grid-col-2"; "inset" ] ] + (multi_select_options + { options = all + ; selected = system_email_templates + ; to_label = to_human + ; to_value = show + } + Message.Field.MessageTemplate + @ [ submit ~classnames:[ "flexrow"; "span-2" ] () ]) + ] + ; open_system_settings_changelog Settings.Key.SystemEmailTemplates + ] + in + ( "System email templates" + , [ form ] + , Some + "Templates selected here use the SMTP system account. If no system account is \ + configured, the default SMTP account will be used." + , [ `UpdateSystemEmailTemplates ] ) + in let inactive_user_html = let open Settings.InactiveUser in let disable_service_form = @@ -502,6 +538,7 @@ let show [ languages_html ; email_suffixes_html ; contact_email_html + ; system_email_templates_html ; inactive_user_html ; trigger_profile_update_after_html ; default_lead_time diff --git a/pool/web/view/page/page_admin_settings_smtp.ml b/pool/web/view/page/page_admin_settings_smtp.ml index 1e8e7992f..8a48f7412 100644 --- a/pool/web/view/page/page_admin_settings_smtp.ml +++ b/pool/web/view/page/page_admin_settings_smtp.ml @@ -1,4 +1,5 @@ open Tyxml.Html +open CCFun.Infix open Component.Input open Pool_message module Icon = Component.Icon @@ -27,6 +28,7 @@ let list Pool_context.{ language; csrf; _ } location smtp_auth_list query = ; `column SmtpAuth.column_smtp_mechanism ; `column SmtpAuth.column_smtp_protocol ; `column SmtpAuth.column_smtp_default_account + ; `column SmtpAuth.column_smtp_system_account ; `custom create_smtp ] in @@ -57,6 +59,8 @@ let list Pool_context.{ language; csrf; _ } location smtp_auth_list query = ; auth.protocol |> Protocol.show |> txt, Some Field.SmtpProtocol ; ( auth.default |> Default.value |> Utils.Bool.to_string |> txt , Some Field.DefaultSmtpServer ) + ; ( auth.system_account |> SystemAccount.value |> Utils.Bool.to_string |> txt + , Some Field.SmtpSystemAccount ) ; ( button_group [ edit_link (Format.asprintf "%s/%s" (base_path location) (auth.id |> Id.value)) ; delete_button auth @@ -92,12 +96,14 @@ let smtp_form_inputs ?flash_fetcher language (smtp_auth : SmtpAuth.t option) = ?(break = false) ?(required = false) ?(field_type = `Text) + ?hints field decode_fcn = input_element ~classnames:(if break then [ "break-grid" ] else []) ~required + ?hints ~value:(smtp_auth |> CCOption.map_or ~default:"" decode_fcn) ?flash_fetcher language @@ -110,35 +116,72 @@ let smtp_form_inputs ?flash_fetcher language (smtp_auth : SmtpAuth.t option) = | None -> input_element_root ~field_type:`Password Field.SmtpPassword (CCFun.const "") in div - ~a:[ a_class [ "grid-col-2"; "flex-gap" ] ] - [ input_element_root ~required:true Field.SmtpLabel (fun smtp -> - smtp.label |> Label.value) - ; input_element_root ~required:true Field.SmtpServer (fun smtp -> - smtp.server |> Server.value) - ; input_element_root ~required:true ~field_type:`Number Field.SmtpPort (fun smtp -> - smtp.port |> Port.value |> CCInt.to_string) - ; selector - ~required:true - language - Field.SmtpMechanism - Mechanism.show - Mechanism.all - (smtp_auth |> CCOption.map (fun smtp -> smtp.mechanism)) - () - ; selector - ~required:true + ~a:[ a_class [ "stack" ] ] + [ div + ~a:[ a_class [ "grid-col-2"; "flex-gap" ] ] + [ input_element_root ~required:true Field.SmtpLabel (label %> Label.value) + ; input_element_root ~required:true Field.SmtpServer (server %> Server.value) + ; input_element_root + ~required:true + ~field_type:`Number + Field.SmtpPort + (port %> Port.value %> CCInt.to_string) + ; selector + ~required:true + language + Field.SmtpMechanism + Mechanism.show + Mechanism.all + (smtp_auth |> CCOption.map mechanism) + () + ; selector + ~required:true + language + Field.SmtpProtocol + Protocol.show + Protocol.all + (smtp_auth |> CCOption.map protocol) + () + ; input_element_root + ~break:true + Field.SmtpUsername + (username %> CCOption.map_or ~default:"" Username.value) + ; password + ; input_element + ~additional_attributes:[ a_input_min (`Number 0); a_step (Some 100.0) ] + ~classnames:[ "break-grid" ] + ~value: + (smtp_auth + |> CCOption.map_or + ~default:RateLimit.(default |> value |> CCInt.to_string) + (rate_limit %> RateLimit.value %> CCInt.to_string)) + language + `Number + Field.SmtpRateLimit + ; input_element + ~additional_attributes: + [ a_input_min (`Number 0); a_step (Some 1.0); a_input_max (`Number 100) ] + ~value: + (smtp_auth + |> CCOption.map_or + ~default:InvitationCapacity.(default |> value |> CCInt.to_string) + (invitation_capacity %> InvitationCapacity.value %> CCInt.to_string)) + language + `Number + Field.SmtpInvitationCapacity + ; input_element_root + ~field_type:`Text + ~hints:[ Pool_common.I18n.SmtpSettingsInternalRegex ] + Field.SmtpInternalRegex + (internal_regex %> CCOption.map_or ~default:"" InternalRegex.value) + ] + ; checkbox_element + ?value:(smtp_auth |> CCOption.map (system_account %> SystemAccount.value)) + ~hints:[ Pool_common.I18n.SmtpSettingsSystemAccountFlag ] language - Field.SmtpProtocol - Protocol.show - Protocol.all - (smtp_auth |> CCOption.map (fun smtp -> smtp.protocol)) - () - ; input_element_root ~break:true Field.SmtpUsername (fun smtp -> - smtp.username |> CCOption.map_or ~default:"" Username.value) - ; password + Field.SmtpSystemAccount ; checkbox_element - ~classnames:[ "break-grid" ] - ?value:(smtp_auth |> CCOption.map (fun smtp -> smtp.default |> Default.value)) + ?value:(smtp_auth |> CCOption.map (default %> Default.value)) ~hints:[ Pool_common.I18n.SmtpSettingsDefaultFlag ] language Field.DefaultSmtpServer diff --git a/yarn.lock b/yarn.lock index 1d226262b..81636730b 100644 --- a/yarn.lock +++ b/yarn.lock @@ -691,9 +691,9 @@ lodash-es "4.17.21" "@econ/frontend-framework@^4.0.0": - version "4.0.15" - resolved "https://gitlab.uzh.ch/api/v4/projects/662/packages/npm/@econ/frontend-framework/-/@econ/frontend-framework-4.0.15.tgz#b7866f81e9743d2c114d81a8d62775af68e6e231" - integrity sha1-t4Zvgel0PSwRTYGo1id1r2jm4jE= + version "4.1.0" + resolved "https://gitlab.uzh.ch/api/v4/projects/662/packages/npm/@econ/frontend-framework/-/@econ/frontend-framework-4.1.0.tgz#08b84dd6ca50e957a5023e8160b9f4ac863b9d02" + integrity sha1-CLhN1spQ6VelAj6BYLn0rIY7nQI= dependencies: flatpickr "^4.6.13" @@ -1548,74 +1548,74 @@ resolved "https://registry.yarnpkg.com/@popperjs/core/-/core-2.11.8.tgz#6b79032e760a0899cd4204710beede972a3a185f" integrity sha512-P1st0aksCrn9sGZhp8GMYwBnQsbvAWsZAX44oXNNvLHGqAOcoVxmjZiohstwQ7SqKnbR47akdNi+uleWD8+g6A== -"@swc/core-darwin-arm64@1.15.13": - version "1.15.13" - resolved "https://registry.yarnpkg.com/@swc/core-darwin-arm64/-/core-darwin-arm64-1.15.13.tgz#f60ff48cb93066b83405074015eb6373ea0cdd77" - integrity sha512-ztXusRuC5NV2w+a6pDhX13CGioMLq8CjX5P4XgVJ21ocqz9t19288Do0y8LklplDtwcEhYGTNdMbkmUT7+lDTg== - -"@swc/core-darwin-x64@1.15.13": - version "1.15.13" - resolved "https://registry.yarnpkg.com/@swc/core-darwin-x64/-/core-darwin-x64-1.15.13.tgz#3838c08653ac53a6508cdc34bfa191281da4ed26" - integrity sha512-cVifxQUKhaE7qcO/y9Mq6PEhoyvN9tSLzCnnFZ4EIabFHBuLtDDO6a+vLveOy98hAs5Qu1+bb5Nv0oa1Pihe3Q== - -"@swc/core-linux-arm-gnueabihf@1.15.13": - version "1.15.13" - resolved "https://registry.yarnpkg.com/@swc/core-linux-arm-gnueabihf/-/core-linux-arm-gnueabihf-1.15.13.tgz#9308b156fae3fe5d12684b86af31ada4255066fc" - integrity sha512-t+xxEzZ48enl/wGGy7SRYd7kImWQ/+wvVFD7g5JZo234g6/QnIgZ+YdfIyjHB+ZJI3F7a2IQHS7RNjxF29UkWw== - -"@swc/core-linux-arm64-gnu@1.15.13": - version "1.15.13" - resolved "https://registry.yarnpkg.com/@swc/core-linux-arm64-gnu/-/core-linux-arm64-gnu-1.15.13.tgz#b150d6091e2bb3cf97dc9712a711d3ba025811a9" - integrity sha512-VndeGvKmTXFn6AGwjy0Kg8i7HccOCE7Jt/vmZwRxGtOfNZM1RLYRQ7MfDLo6T0h1Bq6eYzps3L5Ma4zBmjOnOg== - -"@swc/core-linux-arm64-musl@1.15.13": - version "1.15.13" - resolved "https://registry.yarnpkg.com/@swc/core-linux-arm64-musl/-/core-linux-arm64-musl-1.15.13.tgz#35dd5382554096118ecd1db2928e1f71b56aa41a" - integrity sha512-SmZ9m+XqCB35NddHCctvHFLqPZDAs5j8IgD36GoutufDJmeq2VNfgk5rQoqNqKmAK3Y7iFdEmI76QoHIWiCLyw== - -"@swc/core-linux-x64-gnu@1.15.13": - version "1.15.13" - resolved "https://registry.yarnpkg.com/@swc/core-linux-x64-gnu/-/core-linux-x64-gnu-1.15.13.tgz#03f89bbdce8f07a1bc02a3ef1c93a5b4e81aef2e" - integrity sha512-5rij+vB9a29aNkHq72EXI2ihDZPszJb4zlApJY4aCC/q6utgqFA6CkrfTfIb+O8hxtG3zP5KERETz8mfFK6A0A== - -"@swc/core-linux-x64-musl@1.15.13": - version "1.15.13" - resolved "https://registry.yarnpkg.com/@swc/core-linux-x64-musl/-/core-linux-x64-musl-1.15.13.tgz#27ae66914125bf35724e43bb06b856afed39770c" - integrity sha512-OlSlaOK9JplQ5qn07WiBLibkOw7iml2++ojEXhhR3rbWrNEKCD7sd8+6wSavsInyFdw4PhLA+Hy6YyDBIE23Yw== - -"@swc/core-win32-arm64-msvc@1.15.13": - version "1.15.13" - resolved "https://registry.yarnpkg.com/@swc/core-win32-arm64-msvc/-/core-win32-arm64-msvc-1.15.13.tgz#39776831949a53754d8f62e4730ac9430d1671f3" - integrity sha512-zwQii5YVdsfG8Ti9gIKgBKZg8qMkRZxl+OlYWUT5D93Jl4NuNBRausP20tfEkQdAPSRrMCSUZBM6FhW7izAZRg== - -"@swc/core-win32-ia32-msvc@1.15.13": - version "1.15.13" - resolved "https://registry.yarnpkg.com/@swc/core-win32-ia32-msvc/-/core-win32-ia32-msvc-1.15.13.tgz#995c45c9fd86d9959bc1a7275c4e60ac4efcc12f" - integrity sha512-hYXvyVVntqRlYoAIDwNzkS3tL2ijP3rxyWQMNKaxcCxxkCDto/w3meOK/OB6rbQSkNw0qTUcBfU9k+T0ptYdfQ== - -"@swc/core-win32-x64-msvc@1.15.13": - version "1.15.13" - resolved "https://registry.yarnpkg.com/@swc/core-win32-x64-msvc/-/core-win32-x64-msvc-1.15.13.tgz#b329aec8bb5e84bab49c8f250ebb27f6c27dc213" - integrity sha512-XTzKs7c/vYCcjmcwawnQvlHHNS1naJEAzcBckMI5OJlnrcgW8UtcX9NHFYvNjGtXuKv0/9KvqL4fuahdvlNGKw== +"@swc/core-darwin-arm64@1.15.18": + version "1.15.18" + resolved "https://registry.yarnpkg.com/@swc/core-darwin-arm64/-/core-darwin-arm64-1.15.18.tgz#fb487392f7bbe3179166b9b0d128916e39a627af" + integrity sha512-+mIv7uBuSaywN3C9LNuWaX1jJJ3SKfiJuE6Lr3bd+/1Iv8oMU7oLBjYMluX1UrEPzwN2qCdY6Io0yVicABoCwQ== + +"@swc/core-darwin-x64@1.15.18": + version "1.15.18" + resolved "https://registry.yarnpkg.com/@swc/core-darwin-x64/-/core-darwin-x64-1.15.18.tgz#0e11fb0a80ebd56cb4417138a938ffc789ead492" + integrity sha512-wZle0eaQhnzxWX5V/2kEOI6Z9vl/lTFEC6V4EWcn+5pDjhemCpQv9e/TDJ0GIoiClX8EDWRvuZwh+Z3dhL1NAg== + +"@swc/core-linux-arm-gnueabihf@1.15.18": + version "1.15.18" + resolved "https://registry.yarnpkg.com/@swc/core-linux-arm-gnueabihf/-/core-linux-arm-gnueabihf-1.15.18.tgz#e7cac4b46d66dfd6b0fedea68877a5678fcf3579" + integrity sha512-ao61HGXVqrJFHAcPtF4/DegmwEkVCo4HApnotLU8ognfmU8x589z7+tcf3hU+qBiU1WOXV5fQX6W9Nzs6hjxDw== + +"@swc/core-linux-arm64-gnu@1.15.18": + version "1.15.18" + resolved "https://registry.yarnpkg.com/@swc/core-linux-arm64-gnu/-/core-linux-arm64-gnu-1.15.18.tgz#ca888f41be89887f9f6b4afd1cc38a1a596a655d" + integrity sha512-3xnctOBLIq3kj8PxOCgPrGjBLP/kNOddr6f5gukYt/1IZxsITQaU9TDyjeX6jG+FiCIHjCuWuffsyQDL5Ew1bg== + +"@swc/core-linux-arm64-musl@1.15.18": + version "1.15.18" + resolved "https://registry.yarnpkg.com/@swc/core-linux-arm64-musl/-/core-linux-arm64-musl-1.15.18.tgz#292bb894cf08be522487897f6e2a616cbdd6198a" + integrity sha512-0a+Lix+FSSHBSBOA0XznCcHo5/1nA6oLLjcnocvzXeqtdjnPb+SvchItHI+lfeiuj1sClYPDvPMLSLyXFaiIKw== + +"@swc/core-linux-x64-gnu@1.15.18": + version "1.15.18" + resolved "https://registry.yarnpkg.com/@swc/core-linux-x64-gnu/-/core-linux-x64-gnu-1.15.18.tgz#2241fd6a01d88bac32334812660d80ebae88fd12" + integrity sha512-wG9J8vReUlpaHz4KOD/5UE1AUgirimU4UFT9oZmupUDEofxJKYb1mTA/DrMj0s78bkBiNI+7Fo2EgPuvOJfuAA== + +"@swc/core-linux-x64-musl@1.15.18": + version "1.15.18" + resolved "https://registry.yarnpkg.com/@swc/core-linux-x64-musl/-/core-linux-x64-musl-1.15.18.tgz#7d70f02a383d9dbae18b0d2906ee8b49dfb0b533" + integrity sha512-4nwbVvCphKzicwNWRmvD5iBaZj8JYsRGa4xOxJmOyHlMDpsvvJ2OR2cODlvWyGFH6BYL1MfIAK3qph3hp0Az6g== + +"@swc/core-win32-arm64-msvc@1.15.18": + version "1.15.18" + resolved "https://registry.yarnpkg.com/@swc/core-win32-arm64-msvc/-/core-win32-arm64-msvc-1.15.18.tgz#6ea2b41d224a5ac84e1addf19fbc584e49698b08" + integrity sha512-zk0RYO+LjiBCat2RTMHzAWaMky0cra9loH4oRrLKLLNuL+jarxKLFDA8xTZWEkCPLjUTwlRN7d28eDLLMgtUcQ== + +"@swc/core-win32-ia32-msvc@1.15.18": + version "1.15.18" + resolved "https://registry.yarnpkg.com/@swc/core-win32-ia32-msvc/-/core-win32-ia32-msvc-1.15.18.tgz#0c498802837ef53452c744964cac1391eb889e4d" + integrity sha512-yVuTrZ0RccD5+PEkpcLOBAuPbYBXS6rslENvIXfvJGXSdX5QGi1ehC4BjAMl5FkKLiam4kJECUI0l7Hq7T1vwg== + +"@swc/core-win32-x64-msvc@1.15.18": + version "1.15.18" + resolved "https://registry.yarnpkg.com/@swc/core-win32-x64-msvc/-/core-win32-x64-msvc-1.15.18.tgz#878b48b38225680aad1e486880a6835461519e53" + integrity sha512-7NRmE4hmUQNCbYU3Hn9Tz57mK9Qq4c97ZS+YlamlK6qG9Fb5g/BB3gPDe0iLlJkns/sYv2VWSkm8c3NmbEGjbg== "@swc/core@^1.11.24": - version "1.15.13" - resolved "https://registry.yarnpkg.com/@swc/core/-/core-1.15.13.tgz#19b4117a76576f46b28199ac2f75cad5bc9cdde4" - integrity sha512-0l1gl/72PErwUZuavcRpRAQN9uSst+Nk++niC5IX6lmMWpXoScYx3oq/narT64/sKv/eRiPTaAjBFGDEQiWJIw== + version "1.15.18" + resolved "https://registry.yarnpkg.com/@swc/core/-/core-1.15.18.tgz#9eed29c0267d2c262391d4a2e75a3978e3f9dc74" + integrity sha512-z87aF9GphWp//fnkRsqvtY+inMVPgYW3zSlXH1kJFvRT5H/wiAn+G32qW5l3oEk63KSF1x3Ov0BfHCObAmT8RA== dependencies: "@swc/counter" "^0.1.3" "@swc/types" "^0.1.25" optionalDependencies: - "@swc/core-darwin-arm64" "1.15.13" - "@swc/core-darwin-x64" "1.15.13" - "@swc/core-linux-arm-gnueabihf" "1.15.13" - "@swc/core-linux-arm64-gnu" "1.15.13" - "@swc/core-linux-arm64-musl" "1.15.13" - "@swc/core-linux-x64-gnu" "1.15.13" - "@swc/core-linux-x64-musl" "1.15.13" - "@swc/core-win32-arm64-msvc" "1.15.13" - "@swc/core-win32-ia32-msvc" "1.15.13" - "@swc/core-win32-x64-msvc" "1.15.13" + "@swc/core-darwin-arm64" "1.15.18" + "@swc/core-darwin-x64" "1.15.18" + "@swc/core-linux-arm-gnueabihf" "1.15.18" + "@swc/core-linux-arm64-gnu" "1.15.18" + "@swc/core-linux-arm64-musl" "1.15.18" + "@swc/core-linux-x64-gnu" "1.15.18" + "@swc/core-linux-x64-musl" "1.15.18" + "@swc/core-win32-arm64-msvc" "1.15.18" + "@swc/core-win32-ia32-msvc" "1.15.18" + "@swc/core-win32-x64-msvc" "1.15.18" "@swc/counter@^0.1.3": version "0.1.3" @@ -1636,11 +1636,6 @@ dependencies: "@swc/counter" "^0.1.3" -"@trysound/sax@0.2.0": - version "0.2.0" - resolved "https://registry.yarnpkg.com/@trysound/sax/-/sax-0.2.0.tgz#cccaab758af56761eb7bf37af6f03f326dd798ad" - integrity sha512-L7z9BgrNEcYyUYtF+HaEfiS5ebkh9jXqbszz7pC0hRBPaatV0XjSD3+eHrpqFemQfgwiFF0QPIarnIihIDn7OA== - "@types/color-convert@2.0.4": version "2.0.4" resolved "https://registry.yarnpkg.com/@types/color-convert/-/color-convert-2.0.4.tgz#843398ae71e951dc5415d202dfd5e43108823eeb" @@ -1711,9 +1706,9 @@ base64-js@^1.3.1: integrity sha512-AKpaYlHn8t4SVbOHCy+b5+KKgvR4vrsD8vbvrbiQJps7fKDTkjkDry6ji0rUJjC0kzbNePLwzxq8iypo41qeWA== baseline-browser-mapping@^2.9.0: - version "2.10.0" - resolved "https://registry.yarnpkg.com/baseline-browser-mapping/-/baseline-browser-mapping-2.10.0.tgz#5b09935025bf8a80e29130251e337c6a7fc8cbb9" - integrity sha512-lIyg0szRfYbiy67j9KN8IyeD7q7hcmqnJ1ddWmNt19ItGpNN64mnllmxUNFIOdOm6by97jlL6wfpTTJrmnjWAA== + version "2.10.8" + resolved "https://registry.yarnpkg.com/baseline-browser-mapping/-/baseline-browser-mapping-2.10.8.tgz#23d1cea1a85b181c2b8660b6cfe626dc2fb15630" + integrity sha512-PCLz/LXGBsNTErbtB6i5u4eLpHeMfi93aUv5duMmj6caNu6IphS4q6UevDnL36sZQv9lrP11dbPKGMaXPwMKfQ== blurhash@2.0.5: version "2.0.5" @@ -1846,9 +1841,9 @@ call-bound@^1.0.3, call-bound@^1.0.4: get-intrinsic "^1.3.0" caniuse-lite@^1.0.30001759: - version "1.0.30001774" - resolved "https://registry.yarnpkg.com/caniuse-lite/-/caniuse-lite-1.0.30001774.tgz#0e576b6f374063abcd499d202b9ba1301be29b70" - integrity sha512-DDdwPGz99nmIEv216hKSgLD+D4ikHQHjBC/seF98N9CPqRX4M5mSxT9eTV6oyisnJcuzxtZy4n17yKKQYmYQOA== + version "1.0.30001779" + resolved "https://registry.yarnpkg.com/caniuse-lite/-/caniuse-lite-1.0.30001779.tgz#75e4941d406928ba00c8d7a3ddda0b2cb90d7474" + integrity sha512-U5og2PN7V4DMgF50YPNtnZJGWVLFjjsN3zb6uMT5VGYIewieDj1upwfuVNXf4Kor+89c3iCRJnSzMD5LmTvsfA== chalk@^4.1.2: version "4.1.2" @@ -2159,9 +2154,9 @@ dunder-proto@^1.0.1: gopd "^1.2.0" electron-to-chromium@^1.5.263: - version "1.5.302" - resolved "https://registry.yarnpkg.com/electron-to-chromium/-/electron-to-chromium-1.5.302.tgz#032a5802b31f7119269959c69fe2015d8dad5edb" - integrity sha512-sM6HAN2LyK82IyPBpznDRqlTQAtuSaO+ShzFiWTvoMJLHyZ+Y39r8VMfHzwbU8MVBzQ4Wdn85+wlZl2TLGIlwg== + version "1.5.313" + resolved "https://registry.yarnpkg.com/electron-to-chromium/-/electron-to-chromium-1.5.313.tgz#193e9ae2c2ab6915acb41e833068381e4ef0b3e4" + integrity sha512-QBMrTWEf00GXZmJyx2lbYD45jpI3TUFnNIzJ5BBc8piGUDwMPa1GV6HJWTZVvY/eiN3fSopl7NRbgGp9sZ9LTA== elliptic@^6.5.3, elliptic@^6.6.1: version "6.6.1" @@ -2355,10 +2350,10 @@ ieee754@^1.2.1: resolved "https://registry.yarnpkg.com/ieee754/-/ieee754-1.2.1.tgz#8eb7a10a63fff25d15a57b001586d177d1b0d352" integrity sha512-dcyqhDvX1C46lXZcVqCpK+FtMRQVdIMN6/Df5js2zouUsqG7I6sFxitIC+7KYK29KdXOLHdu9zL4sFnoVQnqaA== -immutable@^5.0.2: - version "5.1.4" - resolved "https://registry.yarnpkg.com/immutable/-/immutable-5.1.4.tgz#e3f8c1fe7b567d56cf26698f31918c241dae8c1f" - integrity sha512-p6u1bG3YSnINT5RQmx/yRZBpenIl30kVxkTLDyHLIMk0gict704Q9n+thfDI7lTRm9vXdDYutVzXhzcThxTnXA== +immutable@^5.1.5: + version "5.1.5" + resolved "https://registry.yarnpkg.com/immutable/-/immutable-5.1.5.tgz#93ee4db5c2a9ab42a4a783069f3c5d8847d40165" + integrity sha512-t7xcm2siw+hlUM68I+UEOK+z84RzmN59as9DZ7P1l0994DKUWV7UXBMQZVxaoMSRQ+PBZbHCOoBt7a2wxOMt+A== inherits@^2.0.1, inherits@^2.0.3, inherits@^2.0.4, inherits@~2.0.3, inherits@~2.0.4: version "2.0.4" @@ -2404,79 +2399,79 @@ json5@^2.2.1, json5@^2.2.3: resolved "https://registry.yarnpkg.com/json5/-/json5-2.2.3.tgz#78cd6f1a19bdc12b73db5ad0c61efd66c1e29283" integrity sha512-XmOWe7eyHYH14cLdVPoyg+GOH3rYX++KpzrylJwSW98t3Nk+U8XOl8FWKOgwtzdb8lXGf6zYwDUzeHMWfxasyg== -lightningcss-android-arm64@1.31.1: - version "1.31.1" - resolved "https://registry.yarnpkg.com/lightningcss-android-arm64/-/lightningcss-android-arm64-1.31.1.tgz#609ff48332adff452a8157a7c2842fd692a8eac4" - integrity sha512-HXJF3x8w9nQ4jbXRiNppBCqeZPIAfUo8zE/kOEGbW5NZvGc/K7nMxbhIr+YlFlHW5mpbg/YFPdbnCh1wAXCKFg== - -lightningcss-darwin-arm64@1.31.1: - version "1.31.1" - resolved "https://registry.yarnpkg.com/lightningcss-darwin-arm64/-/lightningcss-darwin-arm64-1.31.1.tgz#a13da040a7929582bab3ace9a67bdc146e99fc2d" - integrity sha512-02uTEqf3vIfNMq3h/z2cJfcOXnQ0GRwQrkmPafhueLb2h7mqEidiCzkE4gBMEH65abHRiQvhdcQ+aP0D0g67sg== - -lightningcss-darwin-x64@1.31.1: - version "1.31.1" - resolved "https://registry.yarnpkg.com/lightningcss-darwin-x64/-/lightningcss-darwin-x64-1.31.1.tgz#f7482c311273571ec0c2bd8277c1f5f6e90e03a4" - integrity sha512-1ObhyoCY+tGxtsz1lSx5NXCj3nirk0Y0kB/g8B8DT+sSx4G9djitg9ejFnjb3gJNWo7qXH4DIy2SUHvpoFwfTA== - -lightningcss-freebsd-x64@1.31.1: - version "1.31.1" - resolved "https://registry.yarnpkg.com/lightningcss-freebsd-x64/-/lightningcss-freebsd-x64-1.31.1.tgz#91df1bb290f1cb7bb2af832d7d0d8809225e0124" - integrity sha512-1RINmQKAItO6ISxYgPwszQE1BrsVU5aB45ho6O42mu96UiZBxEXsuQ7cJW4zs4CEodPUioj/QrXW1r9pLUM74A== - -lightningcss-linux-arm-gnueabihf@1.31.1: - version "1.31.1" - resolved "https://registry.yarnpkg.com/lightningcss-linux-arm-gnueabihf/-/lightningcss-linux-arm-gnueabihf-1.31.1.tgz#c3cad5ae8b70045f21600dc95295ab6166acf57e" - integrity sha512-OOCm2//MZJ87CdDK62rZIu+aw9gBv4azMJuA8/KB74wmfS3lnC4yoPHm0uXZ/dvNNHmnZnB8XLAZzObeG0nS1g== - -lightningcss-linux-arm64-gnu@1.31.1: - version "1.31.1" - resolved "https://registry.yarnpkg.com/lightningcss-linux-arm64-gnu/-/lightningcss-linux-arm64-gnu-1.31.1.tgz#a5c4f6a5ac77447093f61b209c0bd7fef1f0a3e3" - integrity sha512-WKyLWztD71rTnou4xAD5kQT+982wvca7E6QoLpoawZ1gP9JM0GJj4Tp5jMUh9B3AitHbRZ2/H3W5xQmdEOUlLg== - -lightningcss-linux-arm64-musl@1.31.1: - version "1.31.1" - resolved "https://registry.yarnpkg.com/lightningcss-linux-arm64-musl/-/lightningcss-linux-arm64-musl-1.31.1.tgz#af26ab8f829b727ada0a200938a6c8796ff36900" - integrity sha512-mVZ7Pg2zIbe3XlNbZJdjs86YViQFoJSpc41CbVmKBPiGmC4YrfeOyz65ms2qpAobVd7WQsbW4PdsSJEMymyIMg== - -lightningcss-linux-x64-gnu@1.31.1: - version "1.31.1" - resolved "https://registry.yarnpkg.com/lightningcss-linux-x64-gnu/-/lightningcss-linux-x64-gnu-1.31.1.tgz#a891d44e84b71c0d88959feb9a7522bbf61450ee" - integrity sha512-xGlFWRMl+0KvUhgySdIaReQdB4FNudfUTARn7q0hh/V67PVGCs3ADFjw+6++kG1RNd0zdGRlEKa+T13/tQjPMA== - -lightningcss-linux-x64-musl@1.31.1: - version "1.31.1" - resolved "https://registry.yarnpkg.com/lightningcss-linux-x64-musl/-/lightningcss-linux-x64-musl-1.31.1.tgz#8c8b21def851f4d477fa897b80cb3db2b650bc6e" - integrity sha512-eowF8PrKHw9LpoZii5tdZwnBcYDxRw2rRCyvAXLi34iyeYfqCQNA9rmUM0ce62NlPhCvof1+9ivRaTY6pSKDaA== - -lightningcss-win32-arm64-msvc@1.31.1: - version "1.31.1" - resolved "https://registry.yarnpkg.com/lightningcss-win32-arm64-msvc/-/lightningcss-win32-arm64-msvc-1.31.1.tgz#79000fb8c57e94a91b8fc643e74d5a54407d7080" - integrity sha512-aJReEbSEQzx1uBlQizAOBSjcmr9dCdL3XuC/6HLXAxmtErsj2ICo5yYggg1qOODQMtnjNQv2UHb9NpOuFtYe4w== - -lightningcss-win32-x64-msvc@1.31.1: - version "1.31.1" - resolved "https://registry.yarnpkg.com/lightningcss-win32-x64-msvc/-/lightningcss-win32-x64-msvc-1.31.1.tgz#7f025274c81c7d659829731e09c8b6f442209837" - integrity sha512-I9aiFrbd7oYHwlnQDqr1Roz+fTz61oDDJX7n9tYF9FJymH1cIN1DtKw3iYt6b8WZgEjoNwVSncwF4wx/ZedMhw== +lightningcss-android-arm64@1.32.0: + version "1.32.0" + resolved "https://registry.yarnpkg.com/lightningcss-android-arm64/-/lightningcss-android-arm64-1.32.0.tgz#f033885116dfefd9c6f54787523e3514b61e1968" + integrity sha512-YK7/ClTt4kAK0vo6w3X+Pnm0D2cf2vPHbhOXdoNti1Ga0al1P4TBZhwjATvjNwLEBCnKvjJc2jQgHXH0NEwlAg== + +lightningcss-darwin-arm64@1.32.0: + version "1.32.0" + resolved "https://registry.yarnpkg.com/lightningcss-darwin-arm64/-/lightningcss-darwin-arm64-1.32.0.tgz#50b71871b01c8199584b649e292547faea7af9b5" + integrity sha512-RzeG9Ju5bag2Bv1/lwlVJvBE3q6TtXskdZLLCyfg5pt+HLz9BqlICO7LZM7VHNTTn/5PRhHFBSjk5lc4cmscPQ== + +lightningcss-darwin-x64@1.32.0: + version "1.32.0" + resolved "https://registry.yarnpkg.com/lightningcss-darwin-x64/-/lightningcss-darwin-x64-1.32.0.tgz#35f3e97332d130b9ca181e11b568ded6aebc6d5e" + integrity sha512-U+QsBp2m/s2wqpUYT/6wnlagdZbtZdndSmut/NJqlCcMLTWp5muCrID+K5UJ6jqD2BFshejCYXniPDbNh73V8w== + +lightningcss-freebsd-x64@1.32.0: + version "1.32.0" + resolved "https://registry.yarnpkg.com/lightningcss-freebsd-x64/-/lightningcss-freebsd-x64-1.32.0.tgz#9777a76472b64ed6ff94342ad64c7bafd794a575" + integrity sha512-JCTigedEksZk3tHTTthnMdVfGf61Fky8Ji2E4YjUTEQX14xiy/lTzXnu1vwiZe3bYe0q+SpsSH/CTeDXK6WHig== + +lightningcss-linux-arm-gnueabihf@1.32.0: + version "1.32.0" + resolved "https://registry.yarnpkg.com/lightningcss-linux-arm-gnueabihf/-/lightningcss-linux-arm-gnueabihf-1.32.0.tgz#13ae652e1ab73b9135d7b7da172f666c410ad53d" + integrity sha512-x6rnnpRa2GL0zQOkt6rts3YDPzduLpWvwAF6EMhXFVZXD4tPrBkEFqzGowzCsIWsPjqSK+tyNEODUBXeeVHSkw== + +lightningcss-linux-arm64-gnu@1.32.0: + version "1.32.0" + resolved "https://registry.yarnpkg.com/lightningcss-linux-arm64-gnu/-/lightningcss-linux-arm64-gnu-1.32.0.tgz#417858795a94592f680123a1b1f9da8a0e1ef335" + integrity sha512-0nnMyoyOLRJXfbMOilaSRcLH3Jw5z9HDNGfT/gwCPgaDjnx0i8w7vBzFLFR1f6CMLKF8gVbebmkUN3fa/kQJpQ== + +lightningcss-linux-arm64-musl@1.32.0: + version "1.32.0" + resolved "https://registry.yarnpkg.com/lightningcss-linux-arm64-musl/-/lightningcss-linux-arm64-musl-1.32.0.tgz#6be36692e810b718040802fd809623cffe732133" + integrity sha512-UpQkoenr4UJEzgVIYpI80lDFvRmPVg6oqboNHfoH4CQIfNA+HOrZ7Mo7KZP02dC6LjghPQJeBsvXhJod/wnIBg== + +lightningcss-linux-x64-gnu@1.32.0: + version "1.32.0" + resolved "https://registry.yarnpkg.com/lightningcss-linux-x64-gnu/-/lightningcss-linux-x64-gnu-1.32.0.tgz#0b7803af4eb21cfd38dd39fe2abbb53c7dd091f6" + integrity sha512-V7Qr52IhZmdKPVr+Vtw8o+WLsQJYCTd8loIfpDaMRWGUZfBOYEJeyJIkqGIDMZPwPx24pUMfwSxxI8phr/MbOA== + +lightningcss-linux-x64-musl@1.32.0: + version "1.32.0" + resolved "https://registry.yarnpkg.com/lightningcss-linux-x64-musl/-/lightningcss-linux-x64-musl-1.32.0.tgz#88dc8ba865ddddb1ac5ef04b0f161804418c163b" + integrity sha512-bYcLp+Vb0awsiXg/80uCRezCYHNg1/l3mt0gzHnWV9XP1W5sKa5/TCdGWaR/zBM2PeF/HbsQv/j2URNOiVuxWg== + +lightningcss-win32-arm64-msvc@1.32.0: + version "1.32.0" + resolved "https://registry.yarnpkg.com/lightningcss-win32-arm64-msvc/-/lightningcss-win32-arm64-msvc-1.32.0.tgz#4f30ba3fa5e925f5b79f945e8cc0d176c3b1ab38" + integrity sha512-8SbC8BR40pS6baCM8sbtYDSwEVQd4JlFTOlaD3gWGHfThTcABnNDBda6eTZeqbofalIJhFx0qKzgHJmcPTnGdw== + +lightningcss-win32-x64-msvc@1.32.0: + version "1.32.0" + resolved "https://registry.yarnpkg.com/lightningcss-win32-x64-msvc/-/lightningcss-win32-x64-msvc-1.32.0.tgz#141aa5605645064928902bb4af045fa7d9f4220a" + integrity sha512-Amq9B/SoZYdDi1kFrojnoqPLxYhQ4Wo5XiL8EVJrVsB8ARoC1PWW6VGtT0WKCemjy8aC+louJnjS7U18x3b06Q== lightningcss@^1.30.1: - version "1.31.1" - resolved "https://registry.yarnpkg.com/lightningcss/-/lightningcss-1.31.1.tgz#1a19dd327b547a7eda1d5c296ebe1e72df5a184b" - integrity sha512-l51N2r93WmGUye3WuFoN5k10zyvrVs0qfKBhyC5ogUQ6Ew6JUSswh78mbSO+IU3nTWsyOArqPCcShdQSadghBQ== + version "1.32.0" + resolved "https://registry.yarnpkg.com/lightningcss/-/lightningcss-1.32.0.tgz#b85aae96486dcb1bf49a7c8571221273f4f1e4a9" + integrity sha512-NXYBzinNrblfraPGyrbPoD19C1h9lfI/1mzgWYvXUTe414Gz/X1FD2XBZSZM7rRTrMA8JL3OtAaGifrIKhQ5yQ== dependencies: detect-libc "^2.0.3" optionalDependencies: - lightningcss-android-arm64 "1.31.1" - lightningcss-darwin-arm64 "1.31.1" - lightningcss-darwin-x64 "1.31.1" - lightningcss-freebsd-x64 "1.31.1" - lightningcss-linux-arm-gnueabihf "1.31.1" - lightningcss-linux-arm64-gnu "1.31.1" - lightningcss-linux-arm64-musl "1.31.1" - lightningcss-linux-x64-gnu "1.31.1" - lightningcss-linux-x64-musl "1.31.1" - lightningcss-win32-arm64-msvc "1.31.1" - lightningcss-win32-x64-msvc "1.31.1" + lightningcss-android-arm64 "1.32.0" + lightningcss-darwin-arm64 "1.32.0" + lightningcss-darwin-x64 "1.32.0" + lightningcss-freebsd-x64 "1.32.0" + lightningcss-linux-arm-gnueabihf "1.32.0" + lightningcss-linux-arm64-gnu "1.32.0" + lightningcss-linux-arm64-musl "1.32.0" + lightningcss-linux-x64-gnu "1.32.0" + lightningcss-linux-x64-musl "1.32.0" + lightningcss-win32-arm64-msvc "1.32.0" + lightningcss-win32-x64-msvc "1.32.0" lmdb@2.8.5: version "2.8.5" @@ -2563,9 +2558,9 @@ msgpackr-extract@^3.0.2: "@msgpackr-extract/msgpackr-extract-win32-x64" "3.0.3" msgpackr@^1.11.2, msgpackr@^1.9.5: - version "1.11.8" - resolved "https://registry.yarnpkg.com/msgpackr/-/msgpackr-1.11.8.tgz#8283c79eb6e5d488f6fb3fac4996006baa390614" - integrity sha512-bC4UGzHhVvgDNS7kn9tV8fAucIYUBuGojcaLiz7v+P63Lmtm0Xeji8B/8tYKddALXxJLpwIeBmUN3u64C4YkRA== + version "1.11.9" + resolved "https://registry.yarnpkg.com/msgpackr/-/msgpackr-1.11.9.tgz#1aa99ed379a066374ac82b62f8ad70723bbd3a59" + integrity sha512-FkoAAyyA6HM8wL882EcEyFZ9s7hVADSwG9xrVx3dxxNQAtgADTrJoEWivID82Iv1zWDsv/OtbrrcZAzGzOMdNw== optionalDependencies: msgpackr-extract "^3.0.2" @@ -2594,9 +2589,9 @@ node-gyp-build-optional-packages@5.2.2: detect-libc "^2.0.1" node-releases@^2.0.27: - version "2.0.27" - resolved "https://registry.yarnpkg.com/node-releases/-/node-releases-2.0.27.tgz#eedca519205cf20f650f61d56b070db111231e4e" - integrity sha512-nmh3lCkYZ3grZvqcCH+fjmQ7X+H0OeZgP40OierEaAptX4XofMh5kwNbWh7lBduUzCcV/8kZ+NDLCwm2iorIlA== + version "2.0.36" + resolved "https://registry.yarnpkg.com/node-releases/-/node-releases-2.0.36.tgz#99fd6552aaeda9e17c4713b57a63964a2e325e9d" + integrity sha512-TdC8FSgHz8Mwtw9g5L4gR/Sh9XhSP/0DEkQxfEFXOpiul5IiHgHan2VhYYb6agDSfp4KuvltmGApc8HMgUrIkA== nth-check@^2.0.1: version "2.1.1" @@ -2777,16 +2772,21 @@ safe-buffer@~5.1.0, safe-buffer@~5.1.1: integrity sha512-Gd2UZBJDkXlY7GbJxfsE8/nvKkUEU1G38c1siN6QP6a9PT9MmHB8GnpscSmMJSoF8LOIrt8ud/wPtojys4G6+g== sass@^1.88.0: - version "1.97.3" - resolved "https://registry.yarnpkg.com/sass/-/sass-1.97.3.tgz#9cb59339514fa7e2aec592b9700953ac6e331ab2" - integrity sha512-fDz1zJpd5GycprAbu4Q2PV/RprsRtKC/0z82z0JLgdytmcq0+ujJbJ/09bPGDxCLkKY3Np5cRAOcWiVkLXJURg== + version "1.98.0" + resolved "https://registry.yarnpkg.com/sass/-/sass-1.98.0.tgz#924ce85a3745ccaccd976262fdc1bc0c13aa8e57" + integrity sha512-+4N/u9dZ4PrgzGgPlKnaaRQx64RO0JBKs9sDhQ2pLgN6JQZ25uPQZKQYaBJU48Kd5BxgXoJ4e09Dq7nMcOUW3A== dependencies: chokidar "^4.0.0" - immutable "^5.0.2" + immutable "^5.1.5" source-map-js ">=0.6.2 <2.0.0" optionalDependencies: "@parcel/watcher" "^2.4.1" +sax@^1.5.0: + version "1.5.0" + resolved "https://registry.yarnpkg.com/sax/-/sax-1.5.0.tgz#b5549b671069b7aa392df55ec7574cf411179eb8" + integrity sha512-21IYA3Q5cQf089Z6tgaUTr7lDAyzoTPx5HRtbhsME8Udispad8dC/+sziTNugOEx54ilvatQ9YCzl4KQLPcRHA== + semver@^7.7.1: version "7.7.4" resolved "https://registry.yarnpkg.com/semver/-/semver-7.7.4.tgz#28464e36060e991fa7a11d0279d2d3f3b57a7e8a" @@ -2848,17 +2848,17 @@ supports-color@^7.1.0: has-flag "^4.0.0" svgo@^3: - version "3.3.2" - resolved "https://registry.yarnpkg.com/svgo/-/svgo-3.3.2.tgz#ad58002652dffbb5986fc9716afe52d869ecbda8" - integrity sha512-OoohrmuUlBs8B8o6MB2Aevn+pRIH9zDALSR+6hhqVfa6fRwG/Qw9VUMSMW9VNg2CFc/MTIfabtdOVl9ODIJjpw== + version "3.3.3" + resolved "https://registry.yarnpkg.com/svgo/-/svgo-3.3.3.tgz#8246aee0b08791fde3b0ed22b5661b471fadf58e" + integrity sha512-+wn7I4p7YgJhHs38k2TNjy1vCfPIfLIJWR5MnCStsN8WuuTcBnRKcMHQLMM2ijxGZmDoZwNv8ipl5aTTen62ng== dependencies: - "@trysound/sax" "0.2.0" commander "^7.2.0" css-select "^5.1.0" css-tree "^2.3.1" css-what "^6.1.0" csso "^5.0.5" picocolors "^1.0.0" + sax "^1.5.0" term-size@^2.2.1: version "2.2.1"