diff --git a/pool/app/contact/contact.mli b/pool/app/contact/contact.mli index 4f9e2fbce..ec33c9e35 100644 --- a/pool/app/contact/contact.mli +++ b/pool/app/contact/contact.mli @@ -28,7 +28,7 @@ module NumberOfAssignments : sig end type t = - { user : Sihl_user.t + { user : Service.User.t ; recruitment_channel : RecruitmentChannel.t ; terms_accepted_at : Pool_user.TermsAccepted.t option ; language : Pool_common.Language.t option @@ -76,6 +76,7 @@ val firstname : t -> Pool_user.Firstname.t val lastname : t -> Pool_user.Lastname.t val fullname : t -> string val email_address : t -> Pool_user.EmailAddress.t +val sexp_of_t : t -> Sexplib0.Sexp.t val show : t -> string val find diff --git a/pool/app/contact/dune b/pool/app/contact/dune index 4fecb19b0..7a344b31f 100644 --- a/pool/app/contact/dune +++ b/pool/app/contact/dune @@ -18,6 +18,7 @@ ppx_deriving.enum ppx_deriving.eq ppx_deriving.show + ppx_sexp_conv ppx_variants_conv ppx_yojson_conv))) diff --git a/pool/app/contact/entity.ml b/pool/app/contact/entity.ml index fc6644d07..82eb75ac6 100644 --- a/pool/app/contact/entity.ml +++ b/pool/app/contact/entity.ml @@ -1,11 +1,5 @@ module User = Pool_user -module Sihl_user = struct - include Sihl_user - - let equal m k = CCString.equal m.id k.id -end - module RecruitmentChannel = struct let go m fmt _ = Format.pp_print_string fmt m @@ -74,8 +68,8 @@ type t = ; paused_version : Pool_common.Version.t ; language_version : Pool_common.Version.t ; experiment_type_preference_version : Pool_common.Version.t - ; created_at : Ptime.t - ; updated_at : Ptime.t + ; created_at : Pool_common.Model.Ptime.t + ; updated_at : Pool_common.Model.Ptime.t } [@@deriving eq, show] @@ -127,6 +121,10 @@ let firstname m = m.user |> User.user_firstname let lastname m = m.user |> User.user_lastname let email_address m = m.user.Sihl_user.email |> User.EmailAddress.of_string +let sexp_of_t t = + t |> id |> Pool_common.Id.value |> fun s -> Sexplib0.Sexp.Atom s +;; + module Preview = struct type t = { user : Sihl_user.t diff --git a/pool/app/contact/repo/repo_partial_update.ml b/pool/app/contact/repo/repo_partial_update.ml index 8f934e599..dbec77107 100644 --- a/pool/app/contact/repo/repo_partial_update.ml +++ b/pool/app/contact/repo/repo_partial_update.ml @@ -33,7 +33,7 @@ let partial_update pool (field : Entity.PartialUpdate.t) contact = let open PartialUpdate in match field with | Firstname (version, value) -> - let%lwt (_ : Entity.Sihl_user.t) = + let%lwt (_ : Sihl_user.t) = update_sihl_user pool ~firstname:(value |> Pool_user.Firstname.value) @@ -48,7 +48,7 @@ let partial_update pool (field : Entity.PartialUpdate.t) contact = |sql} ) |> update_user_table | Lastname (version, value) -> - let%lwt (_ : Entity.Sihl_user.t) = + let%lwt (_ : Sihl_user.t) = update_sihl_user pool ~lastname:(value |> Pool_user.Lastname.value) diff --git a/pool/app/custom_field/entity.ml b/pool/app/custom_field/entity.ml index 2f10fd2a4..67c43c735 100644 --- a/pool/app/custom_field/entity.ml +++ b/pool/app/custom_field/entity.ml @@ -168,10 +168,7 @@ module Validation = struct [@@deriving show, eq] module Ptime = struct - include Ptime - - let t_of_yojson = Pool_common.Model.Ptime.t_of_yojson - let yojson_of_t = Pool_common.Model.Ptime.yojson_of_t + include Pool_common.Model.Ptime end module Text = struct diff --git a/pool/app/email/entity.ml b/pool/app/email/entity.ml index 66060ba64..bfff99abf 100644 --- a/pool/app/email/entity.ml +++ b/pool/app/email/entity.ml @@ -2,12 +2,6 @@ module PoolError = Pool_common.Message module Database = Pool_database module User = Pool_user -module Sihl_user = struct - include Sihl_user - - let equal m k = CCString.equal m.id k.id -end - module Sihl_email = struct include Sihl_email diff --git a/pool/app/pool_common/dune b/pool/app/pool_common/dune index 8a91666c9..ca5cc5fa9 100644 --- a/pool/app/pool_common/dune +++ b/pool/app/pool_common/dune @@ -1,7 +1,7 @@ (library ; Cannot just be named as "common" because there is a module common in caqti-driver-mariadb (name pool_common) - (libraries sihl utils) + (libraries service sihl utils) (preprocess (pps ppx_deriving.enum diff --git a/pool/app/pool_common/entity.ml b/pool/app/pool_common/entity.ml index 6a11df386..14125a733 100644 --- a/pool/app/pool_common/entity.ml +++ b/pool/app/pool_common/entity.ml @@ -58,7 +58,7 @@ module Language = struct end module Version = struct - type t = int [@@deriving eq, show, yojson] + type t = int [@@deriving eq, show, yojson, sexp_of] let value m = m let create () = 0 diff --git a/pool/app/pool_common/entity_i18n.ml b/pool/app/pool_common/entity_i18n.ml index 4ac6818f4..8e8a97b26 100644 --- a/pool/app/pool_common/entity_i18n.ml +++ b/pool/app/pool_common/entity_i18n.ml @@ -57,6 +57,7 @@ type nav_link = | Invitations | Locations | LoginInformation + | Login | Logout | Mailings | Overview diff --git a/pool/app/pool_common/locales/i18n_de.ml b/pool/app/pool_common/locales/i18n_de.ml index f5fdb6cee..18908183c 100644 --- a/pool/app/pool_common/locales/i18n_de.ml +++ b/pool/app/pool_common/locales/i18n_de.ml @@ -83,6 +83,7 @@ let nav_link_to_string = function | Invitations -> "Einladungen" | Locations -> "Standorte" | LoginInformation -> "Anmeldeinformationen" + | Login -> "Login" | Logout -> "Logout" | Mailings -> "Versand" | Overview -> "Übersicht" diff --git a/pool/app/pool_common/locales/i18n_en.ml b/pool/app/pool_common/locales/i18n_en.ml index 9056fb7c1..91e6819b4 100644 --- a/pool/app/pool_common/locales/i18n_en.ml +++ b/pool/app/pool_common/locales/i18n_en.ml @@ -75,6 +75,7 @@ let nav_link_to_string = function | I18n -> "Translations" | Invitations -> "Invitations" | LoginInformation -> "Login information" + | Login -> "Login" | Locations -> "Locations" | Logout -> "Logout" | Mailings -> "Mailings" diff --git a/pool/app/pool_common/pool_common.mli b/pool/app/pool_common/pool_common.mli index 22dd3f7ea..b7e67aa6c 100644 --- a/pool/app/pool_common/pool_common.mli +++ b/pool/app/pool_common/pool_common.mli @@ -224,6 +224,7 @@ module Version : sig val equal : t -> t -> bool val pp : Format.formatter -> t -> unit + val sexp_of_t : t -> Ppx_sexp_conv_lib.Sexp.t val show : t -> string val value : t -> int val create : unit -> t diff --git a/pool/app/pool_context/dune b/pool/app/pool_context/dune index c41bc7766..3895d7977 100644 --- a/pool/app/pool_context/dune +++ b/pool/app/pool_context/dune @@ -1,5 +1,10 @@ (library (name pool_context) - (libraries pool_common pool_database pool_tenant sihl utils) + (libraries admin contact pool_common pool_database pool_tenant sihl utils) (preprocess - (pps lwt_ppx ppx_deriving.eq ppx_deriving.show ppx_sexp_conv))) + (pps + lwt_ppx + ppx_deriving.eq + ppx_deriving.show + ppx_sexp_conv + ppx_variants_conv))) diff --git a/pool/app/pool_context/entity.ml b/pool/app/pool_context/entity.ml index 83fd8a1c0..c5ee03635 100644 --- a/pool/app/pool_context/entity.ml +++ b/pool/app/pool_context/entity.ml @@ -1,17 +1,26 @@ module PoolError = Pool_common.Message open Sexplib.Conv +(* TODO: Service.User.t for Admin and Root are placeholders and should be + replaced, when guadrian is implemented *) +type user = + | Admin of Service.User.t + | Contact of Contact.t + | Root of Service.User.t +[@@deriving eq, sexp_of, variants] + type t = { query_language : Pool_common.Language.t option ; language : Pool_common.Language.t ; tenant_db : Pool_database.Label.t ; message : PoolError.Collection.t option ; csrf : string + ; user : user option } [@@deriving sexp_of] -let create (query_language, language, tenant_db, message, csrf) = - { query_language; language; tenant_db; message; csrf } +let create (query_language, language, tenant_db, message, csrf, user) = + { query_language; language; tenant_db; message; csrf; user } ;; let find_context key req = @@ -40,6 +49,13 @@ let find_exn req = let set = set_context key +let find_contact { user; _ } = + match user with + | Some (Contact c) -> Ok c + | None | Some (Admin _) | Some (Root _) -> + Error PoolError.(NotFound Field.User) +;; + module Tenant = struct type t = { tenant : Pool_tenant.t @@ -55,4 +71,9 @@ module Tenant = struct let find = find_context key let set = set_context key + + let get_tenant_languages req = + let open CCResult in + req |> find >|= fun c -> c.tenant_languages + ;; end diff --git a/pool/app/pool_context/pool_context.mli b/pool/app/pool_context/pool_context.mli index 7cf4282a8..c2b28cdc0 100644 --- a/pool/app/pool_context/pool_context.mli +++ b/pool/app/pool_context/pool_context.mli @@ -1,9 +1,19 @@ +type user = + | Admin of Service.User.t + | Contact of Contact.t + | Root of Service.User.t + +val admin : Service.User.t -> user +val contact : Contact.t -> user +val root : Service.User.t -> user + type t = { query_language : Pool_common.Language.t option ; language : Pool_common.Language.t ; tenant_db : Pool_tenant.Database.Label.t ; message : Pool_common.Message.Collection.t option ; csrf : string + ; user : user option } val create @@ -12,11 +22,13 @@ val create * Pool_tenant.Database.Label.t * Pool_common.Message.Collection.t option * string + * user option -> t val find : Rock.Request.t -> (t, Pool_common.Message.error) result val find_exn : Rock.Request.t -> t val set : Rock.Request.t -> t -> Rock.Request.t +val find_contact : t -> (Contact.t, Pool_common.Message.error) result module Tenant : sig type t = @@ -28,4 +40,8 @@ module Tenant : sig val key : t Rock.Context.key val find : Rock.Request.t -> (t, Pool_common.Message.error) result val set : Rock.Request.t -> t -> Rock.Request.t + + val get_tenant_languages + : Rock.Request.t + -> (Pool_common.Language.t list, Pool_common.Message.error) result end diff --git a/pool/routes/routes.ml b/pool/routes/routes.ml index 07cb75b82..bb3bba06f 100644 --- a/pool/routes/routes.ml +++ b/pool/routes/routes.ml @@ -125,7 +125,7 @@ module Admin = struct let middlewares = [ CustomMiddleware.Context.context `Admin () ; CustomMiddleware.Tenant.valid_tenant () - ; CustomMiddleware.Admin.require_admin ~login_path_f:(fun () -> "/login") + ; CustomMiddleware.Admin.require_admin () ] ;; @@ -320,13 +320,13 @@ end module Root = struct let middlewares = [ CustomMiddleware.Root.from_root_only () - ; CustomMiddleware.Context.context `Root () + ; CustomMiddleware.Context.context `Admin () ] ;; let public_routes = let open Handler.Root in - [ get "" (forward_to_entrypoint "/root/tenants") + [ get "" (forward_to_entrypoint "/root/login") ; get "/login" Login.login_get ; post "/login" Login.login_post ; get "/logout" Login.logout @@ -337,10 +337,7 @@ module Root = struct ] ;; - let locked_middlewares = - [ CustomMiddleware.Root.require_root ~login_path_f:(fun () -> "/root/login") - ] - ;; + let locked_middlewares = [ CustomMiddleware.Root.require_root () ] let locked_routes = let open Pool_common.Message.Field in diff --git a/pool/service/service.ml b/pool/service/service.ml index 121e434fa..4b312eb38 100644 --- a/pool/service/service.ml +++ b/pool/service/service.ml @@ -1,7 +1,14 @@ (* Put infrastructure service setup here. This is where you decide which service implementation to use. *) module Migration = Sihl.Database.Migration.MariaDb -module User = Sihl_user.MariaDb + +module User = struct + include Sihl_user.MariaDb + include Sihl_user + + let sexp_of_t t = t.id |> fun s -> Sexplib0.Sexp.Atom s +end + module Token = Sihl_token.MariaDb module PasswordReset = Sihl_user.Password_reset.MakeMariaDb (Token) module EmailTemplate = Sihl_email.Template.MariaDb diff --git a/pool/web/handler/admin_admins.ml b/pool/web/handler/admin_admins.ml index 591f17428..3a3024216 100644 --- a/pool/web/handler/admin_admins.ml +++ b/pool/web/handler/admin_admins.ml @@ -1,7 +1,7 @@ module HttpUtils = Http_utils module Message = HttpUtils.Message -let create_layout req = General.create_tenant_layout `Admin req +let create_layout req = General.create_tenant_layout req let index req = let open Utils.Lwt_result.Infix in diff --git a/pool/web/handler/admin_contacts.ml b/pool/web/handler/admin_contacts.ml index 7bfd0ac3e..6011865f3 100644 --- a/pool/web/handler/admin_contacts.ml +++ b/pool/web/handler/admin_contacts.ml @@ -1,7 +1,7 @@ module HttpUtils = Http_utils module Message = HttpUtils.Message -let create_layout req = General.create_tenant_layout `Admin req +let create_layout req = General.create_tenant_layout req let index req = let open Utils.Lwt_result.Infix in @@ -35,9 +35,7 @@ let detail_view action req = | `Edit -> let user_update_csrf = Htmx.user_update_csrf in let* tenant_languages = - Pool_context.Tenant.find req - |> Lwt_result.lift - >|= fun c -> c.Pool_context.Tenant.tenant_languages + Pool_context.Tenant.get_tenant_languages req |> Lwt_result.lift in let%lwt custom_fields = Custom_field.find_all_by_contact diff --git a/pool/web/handler/admin_custom_field_groups.ml b/pool/web/handler/admin_custom_field_groups.ml index 568ff7145..275b18a9b 100644 --- a/pool/web/handler/admin_custom_field_groups.ml +++ b/pool/web/handler/admin_custom_field_groups.ml @@ -2,7 +2,7 @@ module HttpUtils = Http_utils module Message = Pool_common.Message module Url = Page.Admin.CustomFields.Url -let create_layout req = General.create_tenant_layout `Admin req +let create_layout req = General.create_tenant_layout req let get_group_id req = HttpUtils.get_field_router_param req Message.Field.CustomFieldGroup diff --git a/pool/web/handler/admin_custom_field_options.ml b/pool/web/handler/admin_custom_field_options.ml index c19accda2..2006efde1 100644 --- a/pool/web/handler/admin_custom_field_options.ml +++ b/pool/web/handler/admin_custom_field_options.ml @@ -2,7 +2,7 @@ module HttpUtils = Http_utils module Message = HttpUtils.Message module Url = Page.Admin.CustomFields.Url -let create_layout req = General.create_tenant_layout `Admin req +let create_layout req = General.create_tenant_layout req let get_option_id req = HttpUtils.get_field_router_param @@ -44,7 +44,10 @@ let form ?id req custom_field = |> CCOption.map_or ~default:(Lwt_result.return None) (fun id -> Custom_field.find_option tenant_db id >|= CCOption.pure) in - let%lwt sys_languages = Settings.find_languages tenant_db in + let* custom_field = req |> get_field_id |> Custom_field.find tenant_db in + let* sys_languages = + Pool_context.Tenant.get_tenant_languages req |> Lwt_result.lift + in let flash_fetcher key = Sihl.Web.Flash.find key req in Page.Admin.CustomFieldOptions.detail ?custom_field_option @@ -91,7 +94,9 @@ let write ?id req custom_field = err, error_path, [ HttpUtils.urlencoded_to_flash urlencoded ]) @@ let events = - let%lwt sys_languages = Settings.find_languages tenant_db in + let* sys_languages = + Pool_context.Tenant.get_tenant_languages req |> Lwt_result.lift + in match id with | None -> Cqrs_command.Custom_field_option_command.Create.handle diff --git a/pool/web/handler/admin_custom_fields.ml b/pool/web/handler/admin_custom_fields.ml index 429181779..1fc025871 100644 --- a/pool/web/handler/admin_custom_fields.ml +++ b/pool/web/handler/admin_custom_fields.ml @@ -2,7 +2,7 @@ module HttpUtils = Http_utils module Message = Pool_common.Message module Url = Page.Admin.CustomFields.Url -let create_layout req = General.create_tenant_layout `Admin req +let create_layout req = General.create_tenant_layout req let boolean_fields = Custom_field.boolean_fields |> CCList.map Message.Field.show @@ -82,7 +82,9 @@ let form ?id req model = Custom_field.find tenant_db id >|= CCOption.pure) in let%lwt groups = Custom_field.find_groups_by_model tenant_db model in - let%lwt sys_languages = Settings.find_languages tenant_db in + let* sys_languages = + Pool_context.Tenant.get_tenant_languages req |> Lwt_result.lift + in Page.Admin.CustomFields.detail ?custom_field model @@ -133,7 +135,9 @@ let write ?id req model = @@ let events = let open Lwt_result.Syntax in - let%lwt sys_languages = Settings.find_languages tenant_db in + let* sys_languages = + Pool_context.Tenant.get_tenant_languages req |> Lwt_result.lift + in let* decoded = urlencoded |> Cqrs_command.Custom_field_command.base_decode diff --git a/pool/web/handler/admin_experiments.ml b/pool/web/handler/admin_experiments.ml index aabe9c17a..7cd1d4b16 100644 --- a/pool/web/handler/admin_experiments.ml +++ b/pool/web/handler/admin_experiments.ml @@ -5,7 +5,7 @@ module WaitingList = Admin_experiments_waiting_list module Assignment = Admin_experiments_assignments module Mailings = Admin_experiments_mailing -let create_layout req = General.create_tenant_layout `Admin req +let create_layout req = General.create_tenant_layout req let id req field encode = Sihl.Web.Router.param req @@ Pool_common.Message.Field.show field |> encode @@ -30,12 +30,15 @@ let index req = let new_form req = let open Utils.Lwt_result.Infix in + let open Lwt_result.Syntax in let error_path = "/admin/experiments" in - let result ({ Pool_context.tenant_db; _ } as context) = + let result context = Lwt_result.map_error (fun err -> err, error_path) @@ let flash_fetcher key = Sihl.Web.Flash.find key req in - let%lwt sys_languages = Settings.find_languages tenant_db in + let* sys_languages = + Pool_context.Tenant.get_tenant_languages req |> Lwt_result.lift + in Page.Admin.Experiments.create context sys_languages flash_fetcher |> create_layout req context >|= Sihl.Web.Response.of_html @@ -91,7 +94,9 @@ let detail edit req = |> Lwt.return_ok | true -> let flash_fetcher key = Sihl.Web.Flash.find key req in - let%lwt sys_languages = Settings.find_languages tenant_db in + let* sys_languages = + Pool_context.Tenant.get_tenant_languages req |> Lwt_result.lift + in Page.Admin.Experiments.edit experiment context diff --git a/pool/web/handler/admin_experiments_assignments.ml b/pool/web/handler/admin_experiments_assignments.ml index d6bac5a29..4ef2dda3f 100644 --- a/pool/web/handler/admin_experiments_assignments.ml +++ b/pool/web/handler/admin_experiments_assignments.ml @@ -1,7 +1,7 @@ module HttpUtils = Http_utils module Message = HttpUtils.Message -let create_layout req = General.create_tenant_layout `Admin req +let create_layout req = General.create_tenant_layout req let index req = let open Utils.Lwt_result.Infix in diff --git a/pool/web/handler/admin_experiments_invitations.ml b/pool/web/handler/admin_experiments_invitations.ml index 5e3376466..4d26bee5b 100644 --- a/pool/web/handler/admin_experiments_invitations.ml +++ b/pool/web/handler/admin_experiments_invitations.ml @@ -1,25 +1,21 @@ module HttpUtils = Http_utils module Message = HttpUtils.Message -let invitation_templte_data tenant_db = +let invitation_template_data tenant_db system_languages = let open Lwt_result.Syntax in - let%lwt system_languages = Settings.find_languages tenant_db in - let* i18n_texts = - let%lwt res = - Lwt_list.map_s - (fun lang -> - let find = CCFun.flip (I18n.find_by_key tenant_db) lang in - let* subject = find I18n.Key.InvitationSubject in - let* text = find I18n.Key.InvitationText in - Lwt_result.return (lang, (subject, text))) - system_languages - in - CCList.all_ok res |> Lwt.return + let%lwt res = + Lwt_list.map_s + (fun lang -> + let find = CCFun.flip (I18n.find_by_key tenant_db) lang in + let* subject = find I18n.Key.InvitationSubject in + let* text = find I18n.Key.InvitationText in + Lwt_result.return (lang, (subject, text))) + system_languages in - Lwt.return_ok (system_languages, i18n_texts) + CCList.all_ok res |> Lwt.return ;; -let create_layout req = General.create_tenant_layout `Admin req +let create_layout req = General.create_tenant_layout req let index req = let open Utils.Lwt_result.Infix in @@ -104,7 +100,10 @@ let create req = |> fun ids -> Error Pool_common.Message.(NotFoundList (Field.Contacts, ids)) in - let* system_languages, i18n_texts = invitation_templte_data tenant_db in + let* system_languages = + Pool_context.Tenant.get_tenant_languages req |> Lwt_result.lift + in + let* i18n_texts = invitation_template_data tenant_db system_languages in let%lwt invited_contacts = Invitation.find_multiple_by_experiment_and_contacts tenant_db @@ -152,7 +151,10 @@ let resend req = Lwt_result.map_error (fun err -> err, redirect_path) @@ let* invitation = Invitation.find tenant_db id in let* experiment = Experiment.find tenant_db experiment_id in - let* system_languages, i18n_texts = invitation_templte_data tenant_db in + let* system_languages = + Pool_context.Tenant.get_tenant_languages req |> Lwt_result.lift + in + let* i18n_texts = invitation_template_data tenant_db system_languages in let events = let open Cqrs_command.Invitation_command.Resend in handle { invitation; experiment } system_languages i18n_texts diff --git a/pool/web/handler/admin_experiments_mailing.ml b/pool/web/handler/admin_experiments_mailing.ml index e7c1d8de7..b70c09b5e 100644 --- a/pool/web/handler/admin_experiments_mailing.ml +++ b/pool/web/handler/admin_experiments_mailing.ml @@ -2,7 +2,7 @@ module HttpUtils = Http_utils module Message = HttpUtils.Message module Field = Pool_common.Message.Field -let create_layout req = General.create_tenant_layout `Admin req +let create_layout req = General.create_tenant_layout req let id req field encode = Sihl.Web.Router.param req @@ Field.show field |> encode diff --git a/pool/web/handler/admin_experiments_waiting_list.ml b/pool/web/handler/admin_experiments_waiting_list.ml index 063a75ca0..4fc4e1dc6 100644 --- a/pool/web/handler/admin_experiments_waiting_list.ml +++ b/pool/web/handler/admin_experiments_waiting_list.ml @@ -1,7 +1,7 @@ module HttpUtils = Http_utils module Message = HttpUtils.Message -let create_layout req = General.create_tenant_layout `Admin req +let create_layout req = General.create_tenant_layout req let id req field encode = Sihl.Web.Router.param req @@ Pool_common.Message.Field.show field |> encode diff --git a/pool/web/handler/admin_handlers.ml b/pool/web/handler/admin_handlers.ml index 8863725aa..e6b2d3f72 100644 --- a/pool/web/handler/admin_handlers.ml +++ b/pool/web/handler/admin_handlers.ml @@ -10,7 +10,7 @@ module CustomField = Admin_custom_fields module CustomFieldOption = Admin_custom_field_options module CustomFieldGroup = Admin_custom_field_groups -let create_layout req = General.create_tenant_layout `Admin req +let create_layout req = General.create_tenant_layout req let dashboard req = let result context = diff --git a/pool/web/handler/admin_i18n.ml b/pool/web/handler/admin_i18n.ml index dc245b4f3..f019fb3f4 100644 --- a/pool/web/handler/admin_i18n.ml +++ b/pool/web/handler/admin_i18n.ml @@ -1,7 +1,7 @@ module HttpUtils = Http_utils module Message = HttpUtils.Message -let create_layout req = General.create_tenant_layout `Admin req +let create_layout req = General.create_tenant_layout req module I18nMap = CCMap.Make (struct type t = I18n.Key.t diff --git a/pool/web/handler/admin_location.ml b/pool/web/handler/admin_location.ml index 3fd345e38..622877a91 100644 --- a/pool/web/handler/admin_location.ml +++ b/pool/web/handler/admin_location.ml @@ -2,7 +2,7 @@ module HttpUtils = Http_utils module Message = HttpUtils.Message module Field = Pool_common.Message.Field -let create_layout req = General.create_tenant_layout `Admin req +let create_layout req = General.create_tenant_layout req let id req field encode = Sihl.Web.Router.param req @@ Field.show field |> encode diff --git a/pool/web/handler/admin_session.ml b/pool/web/handler/admin_session.ml index f36134ac3..6554e39d5 100644 --- a/pool/web/handler/admin_session.ml +++ b/pool/web/handler/admin_session.ml @@ -1,7 +1,7 @@ module HttpUtils = Http_utils module Message = HttpUtils.Message -let create_layout req = General.create_tenant_layout `Admin req +let create_layout req = General.create_tenant_layout req (* Use this to extract ids from requests, the params are not named :id, because two ids appear in a route *) @@ -23,7 +23,7 @@ let location urlencoded tenant_db = >>= Pool_location.find tenant_db ;; -let reschedule_messages tenant_db session = +let reschedule_messages tenant_db sys_languages session = let open Lwt_result.Syntax in let open Utils.Lwt_result.Infix in let create_message sys_languages contact (session : Session.t) template = @@ -43,7 +43,6 @@ let reschedule_messages tenant_db session = (("name", name) :: session_overview) in let* assignments = Assignment.find_by_session tenant_db session.Session.id in - let%lwt sys_languages = Settings.find_languages tenant_db in let* default_language = CCList.head_opt sys_languages |> CCOption.to_result Pool_common.Message.(Retrieve Field.Language) @@ -113,7 +112,9 @@ let new_form req = @@ let* experiment = Experiment.find tenant_db experiment_id in let%lwt locations = Pool_location.find_all tenant_db in let flash_fetcher key = Sihl.Web.Flash.find key req in - let%lwt sys_languages = Settings.find_languages tenant_db in + let* sys_languages = + Pool_context.Tenant.get_tenant_languages req |> Lwt_result.lift + in Page.Admin.Session.new_form context experiment @@ -189,7 +190,9 @@ let detail req page = let flash_fetcher key = Sihl.Web.Flash.find key req in let* experiment = Experiment.find tenant_db experiment_id in let%lwt locations = Pool_location.find_all tenant_db in - let%lwt sys_languages = Settings.find_languages tenant_db in + let* sys_languages = + Pool_context.Tenant.get_tenant_languages req |> Lwt_result.lift + in Page.Admin.Session.edit context experiment @@ -266,10 +269,13 @@ let update_handler action req = let* (decoded : Session.reschedule) = urlencoded |> decode |> Lwt_result.lift in + let* system_languages = + Pool_context.Tenant.get_tenant_languages req |> Lwt_result.lift + in let (Session.{ start; duration } : Session.reschedule) = decoded in let* messages = Session.{ session with start; duration } - |> reschedule_messages tenant_db + |> reschedule_messages tenant_db system_languages in decoded |> handle ?parent_session:parent follow_ups session messages @@ -341,7 +347,9 @@ let follow_up req = let* parent_session = Session.find tenant_db session_id in let* experiment = Experiment.find tenant_db experiment_id in let flash_fetcher key = Sihl.Web.Flash.find key req in - let%lwt sys_languages = Settings.find_languages tenant_db in + let* sys_languages = + Pool_context.Tenant.get_tenant_languages req |> Lwt_result.lift + in let%lwt locations = Pool_location.find_all tenant_db in Page.Admin.Session.follow_up context diff --git a/pool/web/handler/admin_settings.ml b/pool/web/handler/admin_settings.ml index d3274f430..bacc46d7a 100644 --- a/pool/web/handler/admin_settings.ml +++ b/pool/web/handler/admin_settings.ml @@ -1,13 +1,16 @@ module HttpUtils = Http_utils module Message = HttpUtils.Message -let create_layout req = General.create_tenant_layout `Admin req +let create_layout req = General.create_tenant_layout req let show req = + let open Lwt_result.Syntax in let result ({ Pool_context.tenant_db; _ } as context) = let open Lwt_result.Infix in Lwt_result.map_error (fun err -> err, "/") - @@ let%lwt languages = Settings.find_languages tenant_db in + @@ let* languages = + Pool_context.Tenant.get_tenant_languages req |> Lwt_result.lift + in let%lwt email_suffixes = Settings.find_email_suffixes tenant_db in let%lwt contact_email = Settings.find_contact_email tenant_db in let%lwt inactive_user_disable_after = @@ -45,6 +48,7 @@ let show req = let update_settings req = let open Utils.Lwt_result.Infix in + let open Lwt_result.Syntax in let open Cqrs_command.Settings_command in let lift = Lwt_result.lift in let%lwt urlencoded = Sihl.Web.Request.to_urlencoded req in @@ -52,62 +56,63 @@ let update_settings req = let result { Pool_context.tenant_db; _ } = Lwt_result.map_error (fun err -> err, redirect_path, [ HttpUtils.urlencoded_to_flash urlencoded ]) - @@ - let events () = - let command_handler = - let open CCResult.Infix in - function - | `UpdateTenantLanguages -> - fun m -> - let%lwt terms_and_conditions = - Settings.find_terms_and_conditions tenant_db - in - m - |> CCList.filter_map (fun (k, _) -> - match CCList.mem k Pool_common.Language.all_codes with - | true -> Some (k |> Pool_common.Language.create) - | false -> None) - |> CCResult.flatten_l - >>= UpdateLanguages.handle terms_and_conditions - |> lift - | `UpdateTenantEmailSuffixes -> - fun m -> m |> UpdateEmailSuffixes.handle |> lift - | `CreateTenantEmailSuffix -> - fun m -> - let%lwt suffixes = Settings.find_email_suffixes tenant_db in - CreateEmailSuffix.(m |> decode >>= handle suffixes) |> lift - | `DeleteTenantEmailSuffix -> - fun m -> - let%lwt suffixes = Settings.find_email_suffixes tenant_db in - DeleteEmailSuffix.(m |> decode >>= handle suffixes) |> lift - | `UpdateDefaultLeadTime -> - fun m -> UpdateDefaultLeadTime.(m |> decode >>= handle) |> lift - | `UpdateTenantContactEmail -> - fun m -> UpdateContactEmail.(m |> decode >>= handle) |> lift - | `UpdateInactiveUserDisableAfter -> - fun m -> InactiveUser.DisableAfter.(m |> decode >>= handle) |> lift - | `UpdateInactiveUserWarning -> - fun m -> InactiveUser.Warning.(m |> decode >>= handle) |> lift - | `UpdateTermsAndConditions -> - fun m -> - let%lwt languages = Settings.find_languages tenant_db in - UpdateTermsAndConditions.(handle languages m) |> lift - | `UpdateTriggerProfileUpdateAfter -> - fun m -> - UpdateTriggerProfileUpdateAfter.(m |> decode >>= handle) |> lift - in - Sihl.Web.Router.param req "action" - |> Settings.action_of_param - |> lift - >>= CCFun.flip command_handler urlencoded - in - let handle = Lwt_list.iter_s (Pool_event.handle_event tenant_db) in - let return_to_settings () = - Http_utils.redirect_to_with_actions - redirect_path - [ Message.set ~success:[ Pool_common.Message.SettingsUpdated ] ] - in - () |> events |>> handle |>> return_to_settings + @@ let* system_languages = + Pool_context.Tenant.get_tenant_languages req |> Lwt_result.lift + in + let events () = + let command_handler = + let open CCResult.Infix in + function + | `UpdateTenantLanguages -> + fun m -> + let%lwt terms_and_conditions = + Settings.find_terms_and_conditions tenant_db + in + m + |> CCList.filter_map (fun (k, _) -> + match CCList.mem k Pool_common.Language.all_codes with + | true -> Some (k |> Pool_common.Language.create) + | false -> None) + |> CCResult.flatten_l + >>= UpdateLanguages.handle terms_and_conditions + |> lift + | `UpdateTenantEmailSuffixes -> + fun m -> m |> UpdateEmailSuffixes.handle |> lift + | `CreateTenantEmailSuffix -> + fun m -> + let%lwt suffixes = Settings.find_email_suffixes tenant_db in + CreateEmailSuffix.(m |> decode >>= handle suffixes) |> lift + | `DeleteTenantEmailSuffix -> + fun m -> + let%lwt suffixes = Settings.find_email_suffixes tenant_db in + DeleteEmailSuffix.(m |> decode >>= handle suffixes) |> lift + | `UpdateDefaultLeadTime -> + fun m -> UpdateDefaultLeadTime.(m |> decode >>= handle) |> lift + | `UpdateTenantContactEmail -> + fun m -> UpdateContactEmail.(m |> decode >>= handle) |> lift + | `UpdateInactiveUserDisableAfter -> + fun m -> InactiveUser.DisableAfter.(m |> decode >>= handle) |> lift + | `UpdateInactiveUserWarning -> + fun m -> InactiveUser.Warning.(m |> decode >>= handle) |> lift + | `UpdateTermsAndConditions -> + fun m -> + UpdateTermsAndConditions.(handle system_languages m) |> lift + | `UpdateTriggerProfileUpdateAfter -> + fun m -> + UpdateTriggerProfileUpdateAfter.(m |> decode >>= handle) |> lift + in + Sihl.Web.Router.param req "action" + |> Settings.action_of_param + |> lift + >>= CCFun.flip command_handler urlencoded + in + let handle = Lwt_list.iter_s (Pool_event.handle_event tenant_db) in + let return_to_settings () = + Http_utils.redirect_to_with_actions + redirect_path + [ Message.set ~success:[ Pool_common.Message.SettingsUpdated ] ] + in + () |> events |>> handle |>> return_to_settings in result |> HttpUtils.extract_happy_path_with_actions req ;; diff --git a/pool/web/handler/contact_assignment.ml b/pool/web/handler/contact_assignment.ml index 91cf17d31..3ea2acd2c 100644 --- a/pool/web/handler/contact_assignment.ml +++ b/pool/web/handler/contact_assignment.ml @@ -13,12 +13,11 @@ let create req = let redirect_path = Format.asprintf "/experiments/%s" (experiment_id |> Pool_common.Id.value) in - let result context = + let result ({ Pool_context.tenant_db; _ } as context) = Lwt_result.map_error (fun err -> err, redirect_path) @@ let open Lwt_result.Syntax in - let tenant_db = context.Pool_context.tenant_db in - let* contact = HttpUtils.get_current_contact tenant_db req in + let* contact = Pool_context.find_contact context |> Lwt_result.lift in let* experiment = Experiment.find_public tenant_db experiment_id contact in let* session = Session.find_public tenant_db id in let* waiting_list = diff --git a/pool/web/handler/contact_experiment.ml b/pool/web/handler/contact_experiment.ml index 9f14279e8..2a8520d27 100644 --- a/pool/web/handler/contact_experiment.ml +++ b/pool/web/handler/contact_experiment.ml @@ -6,17 +6,15 @@ let index req = let open Utils.Lwt_result.Infix in let open Lwt_result.Syntax in let error_path = "/dashboard" in - let result context = + let result ({ Pool_context.tenant_db; _ } as context) = Lwt_result.map_error (fun err -> err, error_path) - @@ - let tenant_db = context.Pool_context.tenant_db in - let* contact = HttpUtils.get_current_contact tenant_db req in - let%lwt expermient_list = - Experiment.find_all_public_by_contact tenant_db contact - in - Page.Contact.Experiment.index expermient_list context - |> create_layout ~active_navigation:"/experiments" req context - >|= Sihl.Web.Response.of_html + @@ let* contact = Pool_context.find_contact context |> Lwt_result.lift in + let%lwt experiment_list = + Experiment.find_all_public_by_contact tenant_db contact + in + Page.Contact.Experiment.index experiment_list context + |> create_layout ~active_navigation:"/experiments" req context + >|= Sihl.Web.Response.of_html in result |> HttpUtils.extract_happy_path req ;; @@ -24,16 +22,15 @@ let index req = let show req = let open Utils.Lwt_result.Infix in let error_path = "/experiments" in - let result context = + let result ({ Pool_context.tenant_db; _ } as context) = Lwt_result.map_error (fun err -> err, error_path) @@ let open Lwt_result.Syntax in - let tenant_db = context.Pool_context.tenant_db in let id = HttpUtils.get_field_router_param req Pool_common.Message.Field.Experiment |> Pool_common.Id.of_string in - let* contact = HttpUtils.get_current_contact tenant_db req in + let* contact = Pool_context.find_contact context |> Lwt_result.lift in let* experiment = Experiment.find_public tenant_db id contact in let* sessions = Session.find_all_public_for_experiment diff --git a/pool/web/handler/contact_general.ml b/pool/web/handler/contact_general.ml index bb20d55f0..e7796a21a 100644 --- a/pool/web/handler/contact_general.ml +++ b/pool/web/handler/contact_general.ml @@ -1 +1 @@ -let create_layout req = General.create_tenant_layout `Contact req +let create_layout req = General.create_tenant_layout req diff --git a/pool/web/handler/contact_session.ml b/pool/web/handler/contact_session.ml index 2d9864821..3e46004b2 100644 --- a/pool/web/handler/contact_session.ml +++ b/pool/web/handler/contact_session.ml @@ -13,12 +13,11 @@ let show req = let error_path = Format.asprintf "/experiments/%s" (experiment_id |> Pool_common.Id.value) in - let result context = + let result ({ Pool_context.tenant_db; _ } as context) = Lwt_result.map_error (fun err -> err, error_path) @@ let open Lwt_result.Syntax in - let tenant_db = context.Pool_context.tenant_db in - let* contact = HttpUtils.get_current_contact tenant_db req in + let* contact = Pool_context.find_contact context |> Lwt_result.lift in let* experiment = Experiment.find_public tenant_db experiment_id contact in let* () = Assignment.find_by_experiment_and_contact_opt diff --git a/pool/web/handler/contact_signup.ml b/pool/web/handler/contact_signup.ml index a7687f269..81c2cc704 100644 --- a/pool/web/handler/contact_signup.ml +++ b/pool/web/handler/contact_signup.ml @@ -85,11 +85,15 @@ let sign_up_create req = let email_verification req = let open Utils.Lwt_result.Infix in - let result { Pool_context.tenant_db; query_language; _ } = + let result ({ Pool_context.tenant_db; query_language; _ } as context) = let open Lwt_result.Syntax in let open Pool_common.Message in let%lwt redirect_path = - let%lwt user = Http_utils.user_from_session tenant_db req in + let user = + Pool_context.find_contact context + |> CCResult.map (fun contact -> contact.Contact.user) + |> CCOption.of_result + in CCOption.bind user (fun user -> Some (General.dashboard_path tenant_db user)) |> CCOption.value ~default:("/login" |> Lwt.return) @@ -111,7 +115,7 @@ let email_verification req = >>= Email.find_unverified_by_address tenant_db |> Lwt_result.map_error (fun _ -> Field.(Invalid Token)) in - let* contact = Contact.find tenant_db (Email.user_id email) in + let* contact = Pool_context.find_contact context |> Lwt_result.lift in let* events = match contact.Contact.user.Sihl.Contract.User.confirmed with | false -> @@ -134,12 +138,12 @@ let terms req = let open Lwt_result.Syntax in let result ({ Pool_context.tenant_db; language; _ } as context) = Lwt_result.map_error (fun err -> err, "/login") - @@ let* user = - Http_utils.user_from_session tenant_db req - ||> CCOption.to_result Pool_common.Message.(NotFound Field.User) - in + @@ let* contact = Pool_context.find_contact context |> Lwt_result.lift in let* terms = Settings.terms_and_conditions tenant_db language in - Page.Contact.terms user.Sihl_user.id terms context + Page.Contact.terms + Contact.(contact |> id |> Pool_common.Id.value) + terms + context |> create_layout req context >|= Sihl.Web.Response.of_html in diff --git a/pool/web/handler/contact_user_profile.ml b/pool/web/handler/contact_user_profile.ml index 8c6411e05..78dc87213 100644 --- a/pool/web/handler/contact_user_profile.ml +++ b/pool/web/handler/contact_user_profile.ml @@ -11,13 +11,7 @@ let show usage req = let open Utils.Lwt_result.Infix in let open Lwt_result.Syntax in Lwt_result.map_error (fun err -> err, "/login") - @@ let* user = - Http_utils.user_from_session tenant_db req - ||> CCOption.to_result Pool_common.Message.(NotFound Field.User) - in - let* contact = - Contact.find tenant_db (user.Sihl_user.id |> Pool_common.Id.of_string) - in + @@ let* contact = Pool_context.find_contact context |> Lwt_result.lift in match usage with | `Overview -> Page.Contact.detail contact context @@ -57,20 +51,14 @@ let login_information = show `LoginInformation let update = Helpers.PartialUpdate.update let update_email req = - let open Utils.Lwt_result.Infix in let open Pool_common.Message in let%lwt urlencoded = Sihl.Web.Request.to_urlencoded req in - let result { Pool_context.tenant_db; query_language; _ } = + let result ({ Pool_context.tenant_db; query_language; _ } as context) = let open Lwt_result.Syntax in Lwt_result.map_error (fun msg -> HttpUtils.( msg, "/user/login-information", [ urlencoded_to_flash urlencoded ])) - @@ let* contact = - Http_utils.user_from_session tenant_db req - ||> CCOption.to_result (NotFound Field.User) - >>= fun user -> - Contact.find tenant_db (user.Sihl_user.id |> Pool_common.Id.of_string) - in + @@ let* contact = Pool_context.find_contact context |> Lwt_result.lift in let%lwt allowed_email_suffixes = let open Utils.Lwt_result.Infix in Settings.find_email_suffixes tenant_db @@ -99,19 +87,13 @@ let update_email req = ;; let update_password req = - let open Utils.Lwt_result.Infix in let%lwt urlencoded = Sihl.Web.Request.to_urlencoded req in - let result { Pool_context.tenant_db; query_language; _ } = + let result ({ Pool_context.tenant_db; query_language; _ } as context) = let open Lwt_result.Syntax in Lwt_result.map_error (fun msg -> HttpUtils.( msg, "/user/login-information", [ urlencoded_to_flash urlencoded ])) - @@ let* contact = - Http_utils.user_from_session tenant_db req - ||> CCOption.to_result Pool_common.Message.(NotFound Field.User) - >>= fun user -> - Contact.find tenant_db (user.Sihl_user.id |> Pool_common.Id.of_string) - in + @@ let* contact = Pool_context.find_contact context |> Lwt_result.lift in let* events = let open CCResult.Infix in Command.UpdatePassword.(decode urlencoded >>= handle contact) @@ -135,14 +117,7 @@ let completion req = Lwt_result.map_error (fun err -> err, "/login") @@ let flash_fetcher key = Sihl.Web.Flash.find key req in - let* user = - Http_utils.user_from_session tenant_db req - ||> CCOption.to_result Pool_common.Message.(NotFound Field.User) - in - let* contact = - Contact.find tenant_db (user.Sihl_user.id |> Pool_common.Id.of_string) - |> Lwt_result.map_error (fun err -> err) - in + let* contact = Pool_context.find_contact context |> Lwt_result.lift in let%lwt custom_fields = Custom_field.find_all_required_by_contact tenant_db (Contact.id contact) in @@ -161,13 +136,13 @@ let completion_post req = ||> HttpUtils.format_request_boolean_values [] ||> HttpUtils.remove_empty_values in - let result { Pool_context.tenant_db; query_language; _ } = + let result ({ Pool_context.tenant_db; query_language; _ } as context) = Lwt_result.map_error (fun err -> HttpUtils.( ( err , path_with_language query_language "/user/completion" , [ urlencoded_to_flash urlencoded ] ))) - @@ let* contact = HttpUtils.get_current_contact tenant_db req in + @@ let* contact = Pool_context.find_contact context |> Lwt_result.lift in let%lwt custom_fields = urlencoded |> CCList.map (fun pair -> pair |> fst |> Pool_common.Id.of_string) diff --git a/pool/web/handler/contact_waiting_list.ml b/pool/web/handler/contact_waiting_list.ml index 28c337554..65b05d395 100644 --- a/pool/web/handler/contact_waiting_list.ml +++ b/pool/web/handler/contact_waiting_list.ml @@ -12,49 +12,48 @@ let handle req action = let redirect_path = Format.asprintf "/experiments/%s" (Pool_common.Id.value experiment_id) in - let result context = + let result ({ Pool_context.tenant_db; _ } as context) = let open Lwt_result.Syntax in Lwt_result.map_error (fun err -> err, redirect_path) - @@ - let tenant_db = context.Pool_context.tenant_db in - let* contact = - Service.User.Web.user_from_session ~ctx:(Pool_tenant.to_ctx tenant_db) req - ||> CCOption.to_result Pool_common.Message.(NotFound Field.User) - >>= Contact.find_by_user tenant_db - in - let* experiment = Experiment.find_public tenant_db experiment_id contact in - let events = - match action with - | `Create -> - Waiting_list.{ contact; experiment } - |> Cqrs_command.Waiting_list_command.Create.handle - |> Lwt_result.lift - | `Destroy -> - let* waiting_list = - Waiting_list.find_by_contact_and_experiment - tenant_db - contact - experiment - in - let open CCResult.Infix in - waiting_list - |> CCOption.to_result Pool_common.Message.(NotFound Field.WaitingList) - >>= Cqrs_command.Waiting_list_command.Destroy.handle - |> Lwt_result.lift - in - let handle events = - let%lwt () = Lwt_list.iter_s (Pool_event.handle_event tenant_db) events in - let success_message = - let open Pool_common.Message in - match action with - | `Create -> AddedToWaitingList - | `Destroy -> RemovedFromWaitingList - in - Http_utils.redirect_to_with_actions - redirect_path - [ Message.set ~success:[ success_message ] ] - in - events |>> handle + @@ let* contact = Pool_context.find_contact context |> Lwt_result.lift in + let* experiment = + Experiment.find_public tenant_db experiment_id contact + in + let events = + match action with + | `Create -> + Waiting_list.{ contact; experiment } + |> Cqrs_command.Waiting_list_command.Create.handle + |> Lwt_result.lift + | `Destroy -> + let* waiting_list = + Waiting_list.find_by_contact_and_experiment + tenant_db + contact + experiment + in + let open CCResult.Infix in + waiting_list + |> CCOption.to_result + Pool_common.Message.(NotFound Field.WaitingList) + >>= Cqrs_command.Waiting_list_command.Destroy.handle + |> Lwt_result.lift + in + let handle events = + let%lwt (_ : unit list) = + Lwt_list.map_s (Pool_event.handle_event tenant_db) events + in + let success_message = + let open Pool_common.Message in + match action with + | `Create -> AddedToWaitingList + | `Destroy -> RemovedFromWaitingList + in + Http_utils.redirect_to_with_actions + redirect_path + [ Message.set ~success:[ success_message ] ] + in + events |>> handle in result |> HttpUtils.extract_happy_path req ;; diff --git a/pool/web/handler/general.ml b/pool/web/handler/general.ml index 0fc1d30a1..1776dd264 100644 --- a/pool/web/handler/general.ml +++ b/pool/web/handler/general.ml @@ -22,21 +22,34 @@ let dashboard_path tenant_db user = ;; let create_tenant_layout - layout_context req ?active_navigation - Pool_context.{ language; query_language; message; _ } + Pool_context.{ language; query_language; message; user; _ } children = let open Lwt_result.Syntax in let* tenant_context = Pool_context.Tenant.find req |> Lwt_result.lift in Page.Layout.Tenant.create_layout - layout_context children tenant_context + user message language query_language active_navigation |> Lwt_result.return ;; + +let create_root_layout + ?active_navigation + Pool_context.{ language; message; user; _ } + children + = + Page.Layout.create_root_layout + children + language + message + user + ?active_navigation + () +;; diff --git a/pool/web/handler/helpers_partial_update.ml b/pool/web/handler/helpers_partial_update.ml index 437f594b2..bc2230535 100644 --- a/pool/web/handler/helpers_partial_update.ml +++ b/pool/web/handler/helpers_partial_update.ml @@ -53,7 +53,9 @@ let update ?contact req = Sihl.Web.Request.to_urlencoded req ||> HttpUtils.format_htmx_request_boolean_values Field.[ Paused |> show ] in - let result { Pool_context.csrf; tenant_db; language; query_language; _ } = + let result + ({ Pool_context.csrf; tenant_db; language; query_language; _ } as context) + = let open Utils.Lwt_result.Syntax in let path_with_lang = HttpUtils.path_with_language query_language in let with_redirect path res = @@ -67,11 +69,9 @@ let update ?contact req = match contact with | Some contact -> Lwt_result.return contact | None -> - Http_utils.user_from_session tenant_db req - ||> CCOption.to_result (NotFound Field.User) - >>= (fun { Sihl_user.id; _ } -> - Contact.find tenant_db (id |> Pool_common.Id.of_string)) - ||> with_redirect "/login" + Pool_context.find_contact context + |> with_redirect "/login" + |> Lwt_result.lift in let back_path = if is_admin diff --git a/pool/web/handler/public.ml b/pool/web/handler/public.ml index 73d651f41..4c04681ac 100644 --- a/pool/web/handler/public.ml +++ b/pool/web/handler/public.ml @@ -3,7 +3,7 @@ module Login = Public_login module Common = Pool_common module Database = Pool_database -let create_layout req = General.create_tenant_layout `Contact req +let create_layout req = General.create_tenant_layout req let root_redirect req = Http_utils.redirect_to @@ -92,7 +92,7 @@ let not_found req = let html = Page.Utils.error_page_not_found language () in match Http_utils.is_req_from_root_host req with | true -> - Page.Layout.create_root_layout html None language () + General.create_root_layout context html |> Sihl.Web.Response.of_html |> Lwt_result.return | false -> @@ -125,28 +125,13 @@ let asset req = ;; let error req = + let query_lang = Http_utils.find_query_lang req in let error_page (title, note) = - Page.Utils.error_page_terminatory title note () + Page.Utils.error_page_terminatory ?lang:query_lang title note () in - let%lwt tenant_error = - let open Lwt_result.Syntax in - let* ({ Pool_context.tenant_db; _ } as context) = - Pool_context.find req |> Lwt_result.lift - in - let* _ = Pool_tenant.find_by_label tenant_db in - ( Common.Message.TerminatoryTenantErrorTitle - , Common.Message.TerminatoryTenantError ) - |> error_page - |> General.create_tenant_layout `Contact req context - in - (match tenant_error with - | Ok tenant_error -> tenant_error - | Error _ -> - ( Common.Message.TerminatoryRootErrorTitle - , Common.Message.TerminatoryRootError ) - |> error_page - |> fun html -> - Page.Layout.create_root_layout html None Pool_common.Language.En ()) + (Common.Message.TerminatoryRootErrorTitle, Common.Message.TerminatoryRootError) + |> error_page + |> Page.Layout.create_error_layout |> Sihl.Web.Response.of_html |> Lwt.return ;; diff --git a/pool/web/handler/public_login.ml b/pool/web/handler/public_login.ml index 681b70c63..e5ca310f0 100644 --- a/pool/web/handler/public_login.ml +++ b/pool/web/handler/public_login.ml @@ -2,7 +2,7 @@ module HttpUtils = Http_utils module Message = HttpUtils.Message let to_ctx = Pool_tenant.to_ctx -let create_layout req = General.create_tenant_layout `Contact req +let create_layout req = General.create_tenant_layout req let redirect_to_dashboard tenant_db user = let open Lwt.Infix in diff --git a/pool/web/handler/root_login.ml b/pool/web/handler/root_login.ml index 7570723e8..36af40102 100644 --- a/pool/web/handler/root_login.ml +++ b/pool/web/handler/root_login.ml @@ -15,7 +15,10 @@ let login_get req = | Some _ -> redirect_to_entrypoint |> Lwt_result.ok | None -> let open Sihl.Web in - Page.Root.Login.login context |> Response.of_html |> Lwt_result.return + Page.Root.Login.login context + |> General.create_root_layout ~active_navigation:"/root/login" context + |> Response.of_html + |> Lwt_result.return in result |> HttpUtils.extract_happy_path req ;; @@ -56,6 +59,9 @@ let request_reset_password_get req = | Some _ -> redirect_to_entrypoint |> Lwt_result.ok | None -> Page.Root.Login.request_reset_password context + |> General.create_root_layout + ~active_navigation:"/root/request-reset-password" + context |> Response.of_html |> Lwt.return_ok in @@ -100,6 +106,9 @@ let reset_password_get req = |> Lwt_result.lift in Page.Root.Login.reset_password token context + |> General.create_root_layout + ~active_navigation:"/root/reset-password" + context |> Response.of_html |> Lwt_result.return in diff --git a/pool/web/handler/root_tenant.ml b/pool/web/handler/root_tenant.ml index c40137d57..5301c92fb 100644 --- a/pool/web/handler/root_tenant.ml +++ b/pool/web/handler/root_tenant.ml @@ -6,12 +6,11 @@ module Update = Root_tenant_update module Database = Pool_database let tenants req = - let ({ Pool_context.csrf; message; _ } as context) = - Pool_context.find_exn req - in + let context = Pool_context.find_exn req in let%lwt tenant_list = Pool_tenant.find_all () in let%lwt root_list = Root.find_all () in - Page.Root.Tenant.list csrf tenant_list root_list message context + Page.Root.Tenant.list tenant_list root_list context + |> General.create_root_layout ~active_navigation:"/root/tenants" context |> Sihl.Web.Response.of_html |> Lwt.return ;; @@ -117,7 +116,10 @@ let tenant_detail req = |> Pool_common.Id.of_string in let* tenant = Pool_tenant.find id in - Page.Root.Tenant.detail tenant context |> Response.of_html |> Lwt.return_ok + Page.Root.Tenant.detail tenant context + |> General.create_root_layout context + |> Response.of_html + |> Lwt.return_ok in result |> HttpUtils.extract_happy_path req ;; diff --git a/pool/web/middleware/middleware_admin.ml b/pool/web/middleware/middleware_admin.ml index e914814ca..25d8b8c71 100644 --- a/pool/web/middleware/middleware_admin.ml +++ b/pool/web/middleware/middleware_admin.ml @@ -1,22 +1,17 @@ module HttpUtils = Http_utils module Message = HttpUtils.Message -let require_admin ~login_path_f = - let open Utils.Lwt_result.Infix in - let fail_action = () |> login_path_f |> HttpUtils.redirect_to in +let require_admin () = + let fail_action req = Http_utils.invalid_session_redirect req None in let filter handler req = let context = Pool_context.find req in + let open Pool_context in match context with - | Error _ -> fail_action - | Ok { Pool_context.tenant_db; _ } -> - Service.User.Web.user_from_session ~ctx:(Pool_tenant.to_ctx tenant_db) req - >|> (function - | Some user -> - Admin.user_is_admin tenant_db user - >|> (function - | false -> fail_action - | true -> handler req) - | None -> fail_action) + | Error _ -> fail_action req + | Ok { user; _ } -> + (match user with + | None | Some (Contact _) | Some (Root _) -> fail_action req + | Some (Admin _) -> handler req) in Rock.Middleware.create ~name:"user.require.admin" ~filter ;; diff --git a/pool/web/middleware/middleware_contact.ml b/pool/web/middleware/middleware_contact.ml index 72543db66..8386ac48d 100644 --- a/pool/web/middleware/middleware_contact.ml +++ b/pool/web/middleware/middleware_contact.ml @@ -5,11 +5,17 @@ let[@warning "-4"] confirmed_and_terms_agreed () = let%lwt confirmed_and_terms_agreed = let open Utils.Lwt_result.Infix in let open Lwt_result.Syntax in - let* context = Pool_context.find req |> Lwt_result.lift in - let pool = context.Pool_context.tenant_db in - let* user = - Service.User.Web.user_from_session ~ctx:(Pool_tenant.to_ctx pool) req - ||> CCOption.to_result Pool_common.Message.(NotFound Field.User) + let* { Pool_context.tenant_db; user; _ } = + Pool_context.find req |> Lwt_result.lift + in + let* contact = + let open Pool_context in + let error = Pool_common.Message.(NotFound Field.User) in + user + |> CCOption.map_or ~default:(Error error) (function + | Contact c -> Ok c + | Admin _ | Root _ -> Error error) + |> Lwt_result.lift in let is_confirmed contact = Lwt_result.lift @@ -18,18 +24,13 @@ let[@warning "-4"] confirmed_and_terms_agreed () = | false -> Error Pool_common.Message.ContactUnconfirmed) in let terms_agreed contact = - let%lwt accepted = Contact.has_terms_accepted pool contact in + let%lwt accepted = Contact.has_terms_accepted tenant_db contact in match accepted with | true -> Lwt.return_ok contact | false -> Lwt.return_error Pool_common.Message.(TermsAndConditionsNotAccepted) in - Pool_common.Id.of_string user.Sihl_user.id - |> Contact.find pool - |> Lwt_result.map_error - (CCFun.const Pool_common.Message.(NotFound Field.Contact)) - >>= is_confirmed - >>= terms_agreed + contact |> is_confirmed >>= terms_agreed in let query_lang = Pool_context.find req @@ -41,11 +42,7 @@ let[@warning "-4"] confirmed_and_terms_agreed () = | Ok _ -> handler req | Error Pool_common.Message.(NotFound Field.User) | Error Pool_common.Message.(NotFound Field.Contact) -> - Http_utils.redirect_to_with_actions - (Http_utils.path_with_language query_lang "/login") - [ Message.set ~error:[ Pool_common.Message.SessionInvalid ] - ; Sihl.Web.Flash.set [ "_redirect_to", req.Rock.Request.target ] - ] + Http_utils.invalid_session_redirect req query_lang | Error Pool_common.Message.(TermsAndConditionsNotAccepted) -> Http_utils.redirect_to_with_actions (Http_utils.path_with_language query_lang "/termsandconditions") @@ -55,10 +52,7 @@ let[@warning "-4"] confirmed_and_terms_agreed () = | Error Pool_common.Message.ContactUnconfirmed -> Http_utils.redirect_to (Http_utils.path_with_language query_lang "/email-confirmation") - | _ -> - Http_utils.redirect_to_with_actions - (Http_utils.path_with_language query_lang "/login") - [ Message.set ~error:[ Pool_common.Message.SessionInvalid ] ] + | _ -> Http_utils.invalid_session_redirect req query_lang in Rock.Middleware.create ~name:"contact.confirmed" ~filter ;; diff --git a/pool/web/middleware/middleware_context.ml b/pool/web/middleware/middleware_context.ml index ab1f5bf7c..9ca85b90a 100644 --- a/pool/web/middleware/middleware_context.ml +++ b/pool/web/middleware/middleware_context.ml @@ -1,4 +1,4 @@ -let context user () = +let context context () = let tenant_db_of_request req : (Pool_database.Label.t, Pool_common.Message.error) result Lwt.t = @@ -67,21 +67,52 @@ let context user () = (Sihl.Web.Flash.find_alert req) Pool_common.Message.Collection.of_string in - let%lwt context = - let* query_lang, language, tenant_db = - match user with - | `Root -> - Lwt_result.return (None, Pool_common.Language.En, Pool_database.root) - | `Admin -> - let* tenant_db = tenant_db_of_request req in - Lwt_result.return (None, Pool_common.Language.En, tenant_db) - | `Contact -> - let* tenant_db = tenant_db_of_request req in - let%lwt language = language_from_request req tenant_db in - Lwt_result.return (query_lang, language, tenant_db) + let find_tenant_user pool = + let open Utils.Lwt_result.Infix in + let%lwt user = + Service.User.Web.user_from_session ~ctx:(Pool_tenant.to_ctx pool) req in - Lwt_result.return - (Pool_context.create (query_lang, language, tenant_db, message, csrf)) + match user with + | None -> Lwt.return_none + | Some user -> + let open Pool_context in + (match%lwt Admin.user_is_admin pool user with + | false -> + user + |> Contact.find_by_user pool + ||> CCResult.to_opt + ||> CCOption.map contact + | true -> user |> admin |> Lwt.return_some) + in + let is_root_request = Http_utils.is_req_from_root_host req in + let%lwt context = + match is_root_request with + | true -> + let pool = Pool_database.root in + let%lwt user = + let open Lwt.Infix in + Service.User.Web.user_from_session ~ctx:(Pool_tenant.to_ctx pool) req + >|= CCFun.flip CCOption.bind (fun user -> + if Sihl_user.is_admin user + then Some (Pool_context.root user) + else None) + in + Pool_context.create + (None, Pool_common.Language.En, pool, message, csrf, user) + |> Lwt_result.return + | false -> + let* tenant_db = tenant_db_of_request req in + let%lwt user = find_tenant_user tenant_db in + (match context with + | `Admin -> + Pool_context.create + (None, Pool_common.Language.En, tenant_db, message, csrf, user) + |> Lwt_result.return + | `Contact -> + let%lwt language = language_from_request req tenant_db in + Pool_context.create + (query_lang, language, tenant_db, message, csrf, user) + |> Lwt_result.return) in match context with | Ok context -> context |> Pool_context.set req |> handler diff --git a/pool/web/middleware/middleware_root.ml b/pool/web/middleware/middleware_root.ml index afa2ec9ad..ef38aebc4 100644 --- a/pool/web/middleware/middleware_root.ml +++ b/pool/web/middleware/middleware_root.ml @@ -6,28 +6,26 @@ let from_root_only () = | true -> handler req | false -> let html = Page.Utils.error_page_not_found language () in - Page.Layout.create_root_layout html None language () + Page.Layout.create_root_layout html Pool_common.Language.En None None () |> Sihl.Web.Response.of_html |> Lwt.return in Rock.Middleware.create ~name:"root.only" ~filter ;; -let require_root ~login_path_f = - let open Utils.Lwt_result.Infix in - let fail_action = () |> login_path_f |> Http_utils.redirect_to in +let require_root () = + let fail_action req = + Http_utils.invalid_session_redirect ~login_path:"/root/login" req None + in let filter handler req = - Service.User.Web.user_from_session - ~ctx:(Pool_tenant.to_ctx Pool_database.root) - req - >|> function - | Some user -> - user - |> Sihl_user.is_admin - |> (function - | false -> fail_action - | true -> handler req) - | None -> fail_action + let context = Pool_context.find req in + let open Pool_context in + match context with + | Error _ -> fail_action req + | Ok { user; _ } -> + (match user with + | None | Some (Contact _) | Some (Admin _) -> fail_action req + | Some (Root _) -> handler req) in Rock.Middleware.create ~name:"user.require.root" ~filter ;; diff --git a/pool/web/utils/http_utils.ml b/pool/web/utils/http_utils.ml index 84689cddd..4e54a474b 100644 --- a/pool/web/utils/http_utils.ml +++ b/pool/web/utils/http_utils.ml @@ -7,14 +7,6 @@ let user_from_session db_pool req : Sihl_user.t option Lwt.t = Service.User.Web.user_from_session ~ctx req ;; -(* TODO[timhub]: remove as soon we added current user to the context *) -let get_current_contact tenant_db req = - let open Utils.Lwt_result.Infix in - Service.User.Web.user_from_session ~ctx:(Pool_tenant.to_ctx tenant_db) req - ||> CCOption.to_result Pool_common.Message.(NotFound Field.User) - >>= Contact.find_by_user tenant_db -;; - let get_field_router_param req field = Sihl.Web.Router.param req Pool_common.Message.Field.(field |> show) ;; @@ -248,3 +240,11 @@ let externalize_path_with_lang lang path = ;; let add_line_breaks = Utils.Html.handle_line_breaks Tyxml.Html.span + +let invalid_session_redirect ?(login_path = "/login") req query_lang = + redirect_to_with_actions + (path_with_language query_lang login_path) + [ Message.set ~error:[ Pool_common.Message.SessionInvalid ] + ; Sihl.Web.Flash.set [ "_redirect_to", req.Rock.Request.target ] + ] +;; diff --git a/pool/web/view/page/page_layout.ml b/pool/web/view/page/page_layout.ml index d16524e4c..2041d20f7 100644 --- a/pool/web/view/page/page_layout.ml +++ b/pool/web/view/page/page_layout.ml @@ -99,6 +99,13 @@ let build_nav_link (url, title) language query_language active_navigation = else nav_link) ;; +let to_main_nav language query_language active_navigation lst = + lst + |> CCList.map (fun item -> + build_nav_link item language query_language active_navigation) + |> nav ~a:[ a_class [ "main-nav" ] ] +;; + module Tenant = struct let i18n_links tenant_languages active_lang = let link_classes = [ "nav-link" ] in @@ -130,33 +137,52 @@ module Tenant = struct tenant_languages) ;; - (* TODO[timhub]: * differ between login status *) - let navigation layout_context language query_language active_navigation = + let navigation + user + language + query_language + active_navigation + tenant_languages + active_lang + = + let open Pool_common.I18n in + let open Pool_context in + let to_main_nav = to_main_nav language query_language active_navigation in + let language_switch = i18n_links tenant_languages active_lang in + let not_logged_in = [ "/login", Login ] |> to_main_nav in + let logout = "/logout", Logout in let nav_links = - let open Pool_common.I18n in - (match layout_context with - | `Contact -> [ "/experiments", Experiments; "/user", Profile ] - | `Admin -> - [ "/admin/dashboard", Dashboard - ; "/admin/experiments", Experiments - ; "/admin/custom-fields", CustomFields - ; "/admin/locations", Locations - ; "/admin/settings", Settings - ; "/admin/i18n", I18n - ; "/admin/contacts", Contacts - ; "/admin/admins", Admins - ]) - @ [ "/logout", Logout ] - |> CCList.map (fun item -> - build_nav_link item language query_language active_navigation) + match user with + | None -> [ not_logged_in; language_switch ] + | Some user -> + (match user with + | Admin _ -> + [ "/admin/dashboard", Dashboard + ; "/admin/experiments", Experiments + ; "/admin/custom-fields", CustomFields + ; "/admin/locations", Locations + ; "/admin/settings", Settings + ; "/admin/i18n", I18n + ; "/admin/contacts", Contacts + ; "/admin/admins", Admins + ; logout + ] + |> to_main_nav + |> CCList.pure + | Contact _ -> + [ [ "/experiments", Experiments; "/user", Profile; logout ] + |> to_main_nav + ; language_switch + ] + | Root _ -> [ not_logged_in ]) in - nav ~a:[ a_class [ "main-nav" ] ] nav_links + nav_links ;; let create_layout - layout_context children Pool_context.Tenant.{ tenant_languages; tenant } + user message active_lang query_language @@ -179,14 +205,15 @@ module Tenant = struct (txt "") in let header_content = - let navigation = - navigation layout_context active_lang query_language active_navigation - in - (fun html -> [ div ~a:[ a_class [ "flexrow"; "flex-gap" ] ] html ]) - @@ - match layout_context with - | `Admin -> [ navigation ] - | `Contact -> [ navigation; i18n_links tenant_languages active_lang ] + navigation + user + active_lang + query_language + active_navigation + tenant_languages + active_lang + |> fun nav -> + nav |> div ~a:[ a_class [ "flexrow"; "flex-gap" ] ] |> CCList.pure in let content = main_tag [ message; children ] in html @@ -203,20 +230,22 @@ module Tenant = struct ;; end -let create_root_layout children message lang ?active_navigation () = - (* TODO[timhub]: * differ between login status *) +let create_root_layout children language message user ?active_navigation () = let navigation = - let nav_links = - let open Pool_common.I18n in - [ "/root/tenants", Tenants ] - |> CCList.map (fun item -> - build_nav_link item Pool_common.Language.En None active_navigation) + let to_main_nav = + to_main_nav Pool_common.Language.En None active_navigation in - nav ~a:[ a_class [ "main-nav" ] ] nav_links + let open Pool_common.I18n in + let open Pool_context in + let not_logged_in = [ "/root/login", Login ] in + (match user with + | None | Some (Contact _) | Some (Admin _) -> not_logged_in + | Some (Root _) -> [ "/root/tenants", Tenants; "/root/logout", Logout ]) + |> to_main_nav in let title_text = "Pool Tool" in let page_title = title (txt title_text) in - let message = Message.create message lang () in + let message = Message.create message language () in let scripts = script ~a:[ a_src (Sihl.Web.externalize_path "/assets/index.js"); a_defer () ] @@ -233,3 +262,19 @@ let create_root_layout children message lang ?active_navigation () = ; scripts ]) ;; + +let create_error_layout children = + let title_text = "Pool Tool" in + let page_title = title (txt title_text) in + let scripts = + script + ~a:[ a_src (Sihl.Web.externalize_path "/assets/index.js"); a_defer () ] + (txt "") + in + let content = main_tag [ children ] in + html + (head page_title ([ charset; viewport; favicon ] @ global_stylesheets)) + (body + ~a:[ a_class body_tag_classnames ] + [ header title_text; content; footer title_text; scripts ]) +;; diff --git a/pool/web/view/page/page_root_login.ml b/pool/web/view/page/page_root_login.ml index 6593c8a92..9a980f3a3 100644 --- a/pool/web/view/page/page_root_login.ml +++ b/pool/web/view/page/page_root_login.ml @@ -2,100 +2,73 @@ open Tyxml.Html open Component module Message = Pool_common.Message -let login Pool_context.{ language; csrf; message; _ } = +let login Pool_context.{ language; csrf; _ } = let input_element = input_element language in - let html = - div - ~a:[ a_class [ "trim"; "narrow" ] ] - [ div - ~a:[ a_class [ "stack" ] ] - [ h1 - ~a:[ a_class [ "heading-1" ] ] - [ txt Pool_common.(Utils.text_to_string language I18n.LoginTitle) + div + ~a:[ a_class [ "trim"; "narrow" ] ] + [ div + ~a:[ a_class [ "stack" ] ] + [ h1 + ~a:[ a_class [ "heading-1" ] ] + [ txt Pool_common.(Utils.text_to_string language I18n.LoginTitle) ] + ; form + ~a: + [ a_action (Sihl.Web.externalize_path "/root/login") + ; a_method `Post + ; a_class [ "stack" ] ] - ; form - ~a: - [ a_action (Sihl.Web.externalize_path "/root/login") - ; a_method `Post - ; a_class [ "stack" ] - ] - [ csrf_element csrf () - ; input_element `Text Message.Field.Email - ; input_element `Password Message.Field.Password - ; submit_element language Message.Login () - ] - ; p - [ a - ~a: - [ a_href - (Sihl.Web.externalize_path - "/root/request-reset-password") - ] - [ txt - Pool_common.( - Utils.text_to_string language I18n.ResetPasswordLink) + [ csrf_element csrf () + ; input_element `Text Message.Field.Email + ; input_element `Password Message.Field.Password + ; submit_element language Message.Login () + ] + ; p + [ a + ~a: + [ a_href + (Sihl.Web.externalize_path "/root/request-reset-password") ] - ] - ] - ] - in - Page_layout.create_root_layout - html - message - language - ~active_navigation:"/root/login" - () + [ txt + Pool_common.( + Utils.text_to_string language I18n.ResetPasswordLink) + ] + ] + ] + ] ;; -let request_reset_password Pool_context.{ language; csrf; message; _ } = +let request_reset_password Pool_context.{ language; csrf; _ } = let input_element = input_element language in - let html = - div - ~a:[ a_class [ "trim"; "narrow" ] ] - [ h1 [ txt "Reset Password" ] - ; form - ~a: - [ a_action - (Sihl.Web.externalize_path "/root/request-reset-password") - ; a_method `Post - ; a_class [ "stack" ] - ] - [ csrf_element csrf () - ; input_element `Text Message.Field.Email - ; submit_element language Message.SendResetLink () + div + ~a:[ a_class [ "trim"; "narrow" ] ] + [ h1 [ txt "Reset Password" ] + ; form + ~a: + [ a_action (Sihl.Web.externalize_path "/root/request-reset-password") + ; a_method `Post + ; a_class [ "stack" ] ] - ] - in - Page_layout.create_root_layout - html - message - language - ~active_navigation:"/root/request-reset-password" - () + [ csrf_element csrf () + ; input_element `Text Message.Field.Email + ; submit_element language Message.SendResetLink () + ] + ] ;; -let reset_password token Pool_context.{ language; csrf; message; _ } = - let html = - div - ~a:[ a_class [ "trim"; "narrow" ] ] - [ h1 [ txt "Reset Password" ] - ; form - ~a: - [ a_action (Sihl.Web.externalize_path "/root/reset-password") - ; a_method `Post - ] - [ csrf_element csrf () - ; input_element language `Hidden ~value:token Message.Field.Token - ; input_element language `Password Message.Field.Password - ; input_element language `Password Message.Field.PasswordConfirmation - ; submit_element language Message.(Save (Some Field.password)) () +let reset_password token Pool_context.{ language; csrf; _ } = + div + ~a:[ a_class [ "trim"; "narrow" ] ] + [ h1 [ txt "Reset Password" ] + ; form + ~a: + [ a_action (Sihl.Web.externalize_path "/root/reset-password") + ; a_method `Post ] - ] - in - Page_layout.create_root_layout - html - message - language - ~active_navigation:"/root/reset-password" - () + [ csrf_element csrf () + ; input_element language `Hidden ~value:token Message.Field.Token + ; input_element language `Password Message.Field.Password + ; input_element language `Password Message.Field.PasswordConfirmation + ; submit_element language Message.(Save (Some Field.password)) () + ] + ] ;; diff --git a/pool/web/view/page/page_root_tenant.ml b/pool/web/view/page/page_root_tenant.ml index cea46b77a..58e524c3a 100644 --- a/pool/web/view/page/page_root_tenant.ml +++ b/pool/web/view/page/page_root_tenant.ml @@ -4,7 +4,7 @@ module File = Pool_common.File module Id = Pool_common.Id module Message = Pool_common.Message -let list csrf tenant_list root_list message Pool_context.{ language; _ } = +let list tenant_list root_list Pool_context.{ language; csrf; _ } = let build_tenant_rows tenant_list = let thead = Pool_common.Message.Field.[ Some Tenant; None ] in let open Pool_tenant in @@ -84,60 +84,51 @@ let list csrf tenant_list root_list message Pool_context.{ language; _ } = (input_element_file language ~allow_multiple:true) [ Field.TenantLogos; Field.PartnerLogos ] in - let html = - div - ~a:[ a_class [ "trim"; "narrow" ] ] - [ h1 - ~a:[ a_class [ "heading-1" ] ] - [ txt Pool_common.(Utils.nav_link_to_string language I18n.Tenants) ] - ; div - ~a:[ a_class [ "stack-lg" ] ] - [ tenant_list - ; div - [ h2 - ~a:[ a_class [ "heading-2" ] ] - [ Pool_common.( - Utils.control_to_string - language - Message.(Create (Some Field.Tenant))) - |> txt + div + ~a:[ a_class [ "trim"; "narrow" ] ] + [ h1 + ~a:[ a_class [ "heading-1" ] ] + [ txt Pool_common.(Utils.nav_link_to_string language I18n.Tenants) ] + ; div + ~a:[ a_class [ "stack-lg" ] ] + [ tenant_list + ; div + [ h2 + ~a:[ a_class [ "heading-2" ] ] + [ Pool_common.( + Utils.control_to_string + language + Message.(Create (Some Field.Tenant))) + |> txt + ] + ; form + ~a: + [ a_action (Sihl.Web.externalize_path "/root/tenants/create") + ; a_method `Post + ; a_enctype "multipart/form-data" + ; a_class [ "stack" ] ] - ; form - ~a: - [ a_action - (Sihl.Web.externalize_path "/root/tenants/create") - ; a_method `Post - ; a_enctype "multipart/form-data" - ; a_class [ "stack" ] - ] - ((csrf_element csrf () :: input_fields) - @ [ submit_element language Message.(Create None) () ]) + ((csrf_element csrf () :: input_fields) + @ [ submit_element language Message.(Create None) () ]) + ] + ; h2 ~a:[ a_class [ "heading-2" ] ] [ txt "Root users" ] + ; root_list + ; form + ~a: + [ a_action (Sihl.Web.externalize_path "/root/root/create") + ; a_method `Post + ; a_class [ "stack" ] ] - ; h2 ~a:[ a_class [ "heading-2" ] ] [ txt "Root users" ] - ; root_list - ; form - ~a: - [ a_action (Sihl.Web.externalize_path "/root/root/create") - ; a_method `Post - ; a_class [ "stack" ] - ] - (CCList.map - (Component.input_element language `Text) - Message.Field.[ Email; Password; Firstname; Lastname ] - @ [ submit_element language Message.(Create (Some Field.root)) () - ]) - ] - ] - in - Page_layout.create_root_layout - html - message - language - ~active_navigation:"/root/tenants" - () + (CCList.map + (Component.input_element language `Text) + Message.Field.[ Email; Password; Firstname; Lastname ] + @ [ submit_element language Message.(Create (Some Field.root)) () ] + ) + ] + ] ;; -let detail (tenant : Pool_tenant.t) Pool_context.{ language; csrf; message; _ } = +let detail (tenant : Pool_tenant.t) Pool_context.{ language; csrf; _ } = let open Pool_tenant in let open Pool_tenant.SmtpAuth in let detail_fields = @@ -263,65 +254,62 @@ let detail (tenant : Pool_tenant.t) Pool_context.{ language; csrf; message; _ } ; delete_img_form (tenant.partner_logo |> Pool_tenant.PartnerLogos.value) ] in - let html = - div - ~a:[ a_class [ "trim"; "narrow" ] ] - [ h1 [ txt (tenant.Pool_tenant.title |> Pool_tenant.Title.value) ] - ; div - ~a:[ a_class [ "stack-lg" ] ] - [ form - ~a: - [ a_action - (Sihl.Web.externalize_path - (Format.asprintf - "/root/tenants/%s/update-detail" - (Id.value tenant.id))) - ; a_method `Post - ; a_enctype "multipart/form-data" - ; a_class [ "stack" ] - ] - ((csrf_element csrf () :: detail_input_fields) - @ [ disabled; submit_element language Message.(Update None) () ]) - ; delete_file_forms - ; form - ~a: - [ a_action - (Sihl.Web.externalize_path - (Format.asprintf - "/root/tenants/%s/update-database" - (Id.value tenant.id))) - ; a_method `Post - ; a_enctype "multipart/form-data" - ; a_class [ "stack" ] - ] - ((csrf_element csrf () :: database_input_fields) - @ [ submit_element language Message.(Update None) () ]) - ; form - ~a: - [ a_action - (Sihl.Web.externalize_path - (Format.asprintf - "/root/tenants/%s/create-operator" - (Id.value tenant.id))) - ; a_method `Post - ; a_class [ "stack" ] - ] - ((csrf_element csrf () - :: CCList.map - (Component.input_element language `Text) - Message.Field.[ Email; Password; Firstname; Lastname ]) - @ [ submit_element - language - Message.(Create (Some Field.operator)) - () - ]) - ; p - [ a - ~a:[ a_href (Sihl.Web.externalize_path "/root/tenants") ] - [ txt "back" ] + div + ~a:[ a_class [ "trim"; "narrow" ] ] + [ h1 [ txt (tenant.Pool_tenant.title |> Pool_tenant.Title.value) ] + ; div + ~a:[ a_class [ "stack-lg" ] ] + [ form + ~a: + [ a_action + (Sihl.Web.externalize_path + (Format.asprintf + "/root/tenants/%s/update-detail" + (Id.value tenant.id))) + ; a_method `Post + ; a_enctype "multipart/form-data" + ; a_class [ "stack" ] ] - ] - ] - in - Page_layout.create_root_layout html message language () + ((csrf_element csrf () :: detail_input_fields) + @ [ disabled; submit_element language Message.(Update None) () ]) + ; delete_file_forms + ; form + ~a: + [ a_action + (Sihl.Web.externalize_path + (Format.asprintf + "/root/tenants/%s/update-database" + (Id.value tenant.id))) + ; a_method `Post + ; a_enctype "multipart/form-data" + ; a_class [ "stack" ] + ] + ((csrf_element csrf () :: database_input_fields) + @ [ submit_element language Message.(Update None) () ]) + ; form + ~a: + [ a_action + (Sihl.Web.externalize_path + (Format.asprintf + "/root/tenants/%s/create-operator" + (Id.value tenant.id))) + ; a_method `Post + ; a_class [ "stack" ] + ] + ((csrf_element csrf () + :: CCList.map + (Component.input_element language `Text) + Message.Field.[ Email; Password; Firstname; Lastname ]) + @ [ submit_element + language + Message.(Create (Some Field.operator)) + () + ]) + ; p + [ a + ~a:[ a_href (Sihl.Web.externalize_path "/root/tenants") ] + [ txt "back" ] + ] + ] + ] ;;