diff --git a/pool/app/pool_common/entity_i18n.ml b/pool/app/pool_common/entity_i18n.ml index 268349a32..095e63035 100644 --- a/pool/app/pool_common/entity_i18n.ml +++ b/pool/app/pool_common/entity_i18n.ml @@ -314,6 +314,7 @@ type hint = | SessionReminderLanguageHint | SessionReminderLeadTime | SettingsNoEmailSuffixes + | SettingsPageScripts | SignUpCodeHint | SignUpForWaitingList | SmtpSettingsDefaultFlag diff --git a/pool/app/pool_common/locales/i18n_de.ml b/pool/app/pool_common/locales/i18n_de.ml index 88d3b5c70..4f3612231 100644 --- a/pool/app/pool_common/locales/i18n_de.ml +++ b/pool/app/pool_common/locales/i18n_de.ml @@ -668,6 +668,9 @@ Wenn keine der Checkboxen angewählt ist, bedeutet das, dass der Kontakt erschie | SettingsNoEmailSuffixes -> "Es sind keine Email-Endungen definiert, die zugelassen sind. Das bedeutet, dass \ alle Email-Endungen erlaubt sind." + | SettingsPageScripts -> + "Hier können Sie JavaScript Code einfügen, der auf jeder Seite im Head, bzw. im Body \ + Tag gerendered wird, zum Beispiel ein Matomo Analytics Code." | SignUpCodeHint -> Format.asprintf "Um zu verfolgen, über welche Kanäle sich Kontakte beim Pool registrieren, können \ diff --git a/pool/app/pool_common/locales/i18n_en.ml b/pool/app/pool_common/locales/i18n_en.ml index ac0389e2b..abf4fe6a5 100644 --- a/pool/app/pool_common/locales/i18n_en.ml +++ b/pool/app/pool_common/locales/i18n_en.ml @@ -640,6 +640,9 @@ If you trigger the reminders manually now, no more automatic reminders will be s | SettingsNoEmailSuffixes -> "There are no email suffixes defined that are allowed. This means that all email \ suffixes are allowed." + | SettingsPageScripts -> + "Here you can insert JavaScript code that is rendered on every page in the head or \ + body tag, e.g. a Matomo analytics code." | SignUpCodeHint -> Format.asprintf "URLs with codes can be sent to track the channels through which contacts register \ diff --git a/pool/app/pool_common/locales/locales_de.ml b/pool/app/pool_common/locales/locales_de.ml index 783797ec2..e0fc45e55 100644 --- a/pool/app/pool_common/locales/locales_de.ml +++ b/pool/app/pool_common/locales/locales_de.ml @@ -200,6 +200,8 @@ let rec field_to_string = | Override -> "Überschreiben" | Page -> "Seite" | PageCount -> "Anzahl Seiten" + | PageScriptsHead -> "Seiten Head Scripts" + | PageScriptsBody -> "Seiten Body Scripts" | Participant | Participants -> "Teilnehmer" | ParticipantCount -> "Teilnehmer" | Participated -> "teilgenommen" diff --git a/pool/app/pool_common/locales/locales_en.ml b/pool/app/pool_common/locales/locales_en.ml index aa8b0ee56..d88ab34ce 100644 --- a/pool/app/pool_common/locales/locales_en.ml +++ b/pool/app/pool_common/locales/locales_en.ml @@ -199,6 +199,8 @@ let rec field_to_string = | Override -> "override" | Page -> "page" | PageCount -> "nr of pages" + | PageScriptsHead -> "page head scripts" + | PageScriptsBody -> "page body scripts" | Participant -> "participant" | ParticipantCount -> "participants" | Participants -> "participants" diff --git a/pool/app/pool_database/migrations/migration_202412131612.ml b/pool/app/pool_database/migrations/migration_202412131612.ml new file mode 100644 index 000000000..3efc36fba --- /dev/null +++ b/pool/app/pool_database/migrations/migration_202412131612.ml @@ -0,0 +1,20 @@ +let create_page_scripts_table = + Database.Migration.Step.create + ~label:"create pool versions table" + {sql| + CREATE TABLE IF NOT EXISTS pool_tenant_page_scripts ( + id BIGINT UNSIGNED AUTO_INCREMENT, + uuid BINARY(16) NOT NULL, + location VARCHAR(128) NOT NULL, + script TEXT NULL, + created_at timestamp NOT NULL DEFAULT CURRENT_TIMESTAMP, + updated_at timestamp NOT NULL DEFAULT CURRENT_TIMESTAMP ON UPDATE CURRENT_TIMESTAMP, + PRIMARY KEY (id), + CONSTRAINT unique_tag UNIQUE KEY (location) + ) ENGINE=InnoDB DEFAULT CHARSET=utf8mb4 COLLATE=utf8mb4_unicode_ci + |sql} +;; + +let migration () = + Database.Migration.(empty "202412131612" |> add_step create_page_scripts_table) +;; diff --git a/pool/app/pool_database/tenant.ml b/pool/app/pool_database/tenant.ml index 3de6e7720..308da1dfb 100644 --- a/pool/app/pool_database/tenant.ml +++ b/pool/app/pool_database/tenant.ml @@ -71,6 +71,7 @@ let steps = ; Migration_202408081359.migration () ; Migration_202410071409.migration () ; Migration_202410161017.migration () + ; Migration_202412131612.migration () ] |> sort in diff --git a/pool/app/settings/entity.ml b/pool/app/settings/entity.ml index 7b1e80d2a..a9955933d 100644 --- a/pool/app/settings/entity.ml +++ b/pool/app/settings/entity.ml @@ -179,6 +179,23 @@ module Write = struct type t = { value : Value.t } end +module PageScript = struct + include Pool_model.Base.String + + type location = + | Head [@name "head"] [@printer Utils.ppx_printer "head"] + | Body [@name "body"] [@printer Utils.ppx_printer "body"] + [@@deriving eq, show { with_path = false }, yojson] + + let schema field () = schema field () + let of_string m = m + + type page_scripts = + { head : t option + ; body : t option + } +end + let action_of_param = function | "create_emailsuffix" -> Ok `CreateEmailSuffix | "delete_emailsuffix" -> Ok `DeleteEmailSuffix @@ -192,6 +209,8 @@ let action_of_param = function | "update_trigger_profile_update_after" -> Ok `UpdateTriggerProfileUpdateAfter | "user_import_first_reminder_after" -> Ok `UserImportFirstReminderAfter | "user_import_second_reminder_after" -> Ok `UserImportSecondReminderAfter + | "update_head_scripts" -> Ok `UpdateHeadScripts + | "update_body_scripts" -> Ok `UpdateBodyScripts | _ -> Error Pool_message.Error.DecodeAction ;; @@ -208,6 +227,8 @@ let stringify_action = function | `UpdateTriggerProfileUpdateAfter -> "update_trigger_profile_update_after" | `UserImportFirstReminderAfter -> "user_import_first_reminder_after" | `UserImportSecondReminderAfter -> "user_import_second_reminder_after" + | `UpdateHeadScripts -> "update_head_scripts" + | `UpdateBodyScripts -> "update_body_scripts" ;; let default_email_session_reminder_lead_time_key_yojson = diff --git a/pool/app/settings/event.ml b/pool/app/settings/event.ml index 026dfdd0c..bb018fb0f 100644 --- a/pool/app/settings/event.ml +++ b/pool/app/settings/event.ml @@ -11,6 +11,7 @@ type event = | TriggerProfileUpdateAfterUpdated of TriggerProfileUpdateAfter.t | UserImportFirstReminderAfterUpdated of UserImportReminder.FirstReminderAfter.t | UserImportSecondReminderAfterUpdated of UserImportReminder.SecondReminderAfter.t + | PageScriptUpdated of (PageScript.t option * PageScript.location) [@@deriving eq, show] let handle_event ?user_uuid pool : event -> unit Lwt.t = @@ -46,4 +47,5 @@ let handle_event ?user_uuid pool : event -> unit Lwt.t = handle_update (Value.UserImportFirstReminder first_reminder_after) | UserImportSecondReminderAfterUpdated second_reminder_after -> handle_update (Value.UserImportSecondReminder second_reminder_after) + | PageScriptUpdated script -> Repo.PageScripts.update pool script ;; diff --git a/pool/app/settings/repo/repo.ml b/pool/app/settings/repo/repo.ml index f0c10c935..f0ab5243e 100644 --- a/pool/app/settings/repo/repo.ml +++ b/pool/app/settings/repo/repo.ml @@ -139,3 +139,76 @@ let upsert pool ?(id = Pool_common.Id.create ()) (value : Entity.Value.t) = let delete pool key = Sql.delete pool (key |> Entity.yojson_of_setting_key |> Yojson.Safe.to_string) ;; + +module PageScripts = struct + open Entity.PageScript + + module Cache = struct + open Hashtbl + + let tbl : (Database.Label.t, page_scripts) t = create 5 + let find = find_opt tbl + let add database_label = replace tbl database_label + let update = add + let clear () = clear tbl + end + + let update_request = + let open Caqti_request.Infix in + {sql| + INSERT INTO pool_tenant_page_scripts ( + uuid, + location, + script + ) VALUES ( + UNHEX(REPLACE(UUID(), '-', '')), + $1, + $2 + ) ON DUPLICATE KEY UPDATE + script = VALUES(script) + |sql} + |> Caqti_type.(t2 string string ->. Caqti_type.unit) + ;; + + let clear_request = + let open Caqti_request.Infix in + {sql| + UPDATE pool_tenant_page_scripts + SET script = NULL + WHERE location = ? + |sql} + |> Caqti_type.(string ->. unit) + ;; + + let update pool (script, location) = + match script with + | None -> Database.exec pool clear_request (show_location location) + | Some script -> Database.exec pool update_request (show_location location, script) + ;; + + let find_request = + let open Caqti_request.Infix in + {sql| + SELECT + script + FROM + pool_tenant_page_scripts + WHERE + location = ? + |sql} + |> Caqti_type.(string ->? string) + ;; + + let find pool location = Database.find_opt pool find_request (show_location location) + + let find pool = + match Cache.find pool with + | Some scripts -> Lwt.return scripts + | None -> + let%lwt head = find pool Head in + let%lwt body = find pool Body in + let scripts = { head; body } in + Cache.add pool scripts; + Lwt.return scripts + ;; +end diff --git a/pool/app/settings/repo/repo_entity.ml b/pool/app/settings/repo/repo_entity.ml index c60758ec9..6234ef96b 100644 --- a/pool/app/settings/repo/repo_entity.ml +++ b/pool/app/settings/repo/repo_entity.ml @@ -3,31 +3,23 @@ open Entity let encode_key_value value = (let open Value in match value with - | DefaultReminderLeadTime v -> - yojson_of_setting_key ReminderLeadTime, yojson_of_default_reminder_lead_time v + | DefaultReminderLeadTime v -> ReminderLeadTime, yojson_of_default_reminder_lead_time v | DefaultTextMsgReminderLeadTime v -> - ( yojson_of_setting_key TextMsgReminderLeadTime - , yojson_of_default_text_msg_reminder_lead_time v ) - | TenantLanguages v -> yojson_of_setting_key Languages, yojson_of_tenant_languages v - | TenantEmailSuffixes v -> - yojson_of_setting_key EmailSuffixes, yojson_of_tenant_email_suffixes v - | TenantContactEmail v -> - yojson_of_setting_key ContactEmail, yojson_of_tenant_contact_email v + TextMsgReminderLeadTime, yojson_of_default_text_msg_reminder_lead_time v + | TenantLanguages v -> Languages, yojson_of_tenant_languages v + | TenantEmailSuffixes v -> EmailSuffixes, yojson_of_tenant_email_suffixes v + | TenantContactEmail v -> ContactEmail, yojson_of_tenant_contact_email v | InactiveUserDisableAfter v -> - ( yojson_of_setting_key InactiveUserDisableAfter - , yojson_of_inactive_user_disable_after v ) - | InactiveUserWarning v -> - yojson_of_setting_key InactiveUserWarning, yojson_of_inactive_user_warning v + InactiveUserDisableAfter, yojson_of_inactive_user_disable_after v + | InactiveUserWarning v -> InactiveUserWarning, yojson_of_inactive_user_warning v | TriggerProfileUpdateAfter v -> - ( yojson_of_setting_key TriggerProfileUpdateAfter - , yojson_of_trigger_profile_update_after v ) + TriggerProfileUpdateAfter, yojson_of_trigger_profile_update_after v | UserImportFirstReminder v -> - ( yojson_of_setting_key UserImportFirstReminderAfter - , UserImportReminder.FirstReminderAfter.yojson_of_t v ) + UserImportFirstReminderAfter, UserImportReminder.FirstReminderAfter.yojson_of_t v | UserImportSecondReminder v -> - ( yojson_of_setting_key UserImportSecondReminderAfter - , UserImportReminder.SecondReminderAfter.yojson_of_t v )) - |> fun (m, k) -> m |> Yojson.Safe.to_string, k |> Yojson.Safe.to_string + UserImportSecondReminderAfter, UserImportReminder.SecondReminderAfter.yojson_of_t v) + |> fun (m, k) -> + m |> yojson_of_setting_key |> Yojson.Safe.to_string, k |> Yojson.Safe.to_string ;; let t = diff --git a/pool/app/settings/settings.ml b/pool/app/settings/settings.ml index c634c824c..38f9248b1 100644 --- a/pool/app/settings/settings.ml +++ b/pool/app/settings/settings.ml @@ -125,3 +125,10 @@ let default_language pool = let open Utils.Lwt_result.Infix in find_languages pool ||> default_language_of_list ;; + +module PageScript = struct + include PageScript + + let find = Repo.PageScripts.find + let clear_cache = Repo.PageScripts.Cache.clear +end diff --git a/pool/app/settings/settings.mli b/pool/app/settings/settings.mli index 6c8039532..8f39e6f87 100644 --- a/pool/app/settings/settings.mli +++ b/pool/app/settings/settings.mli @@ -66,6 +66,27 @@ end type t +module PageScript : sig + include Pool_model.Base.StringSig + + type location = + | Head + | Body + + type page_scripts = + { head : t option + ; body : t option + } + + val schema + : Pool_message.Field.t + -> unit + -> (Pool_message.Error.t, t) Pool_conformist.Field.t + + val find : Database.Label.t -> page_scripts Lwt.t + val clear_cache : unit -> unit +end + val action_of_param : string -> ( [> `CreateEmailSuffix @@ -80,6 +101,8 @@ val action_of_param | `UpdateTriggerProfileUpdateAfter | `UserImportFirstReminderAfter | `UserImportSecondReminderAfter + | `UpdateHeadScripts + | `UpdateBodyScripts ] , Pool_message.Error.t ) result @@ -97,6 +120,8 @@ val stringify_action | `UpdateTriggerProfileUpdateAfter | `UserImportFirstReminderAfter | `UserImportSecondReminderAfter + | `UpdateHeadScripts + | `UpdateBodyScripts ] -> string @@ -111,6 +136,7 @@ type event = | TriggerProfileUpdateAfterUpdated of TriggerProfileUpdateAfter.t | UserImportFirstReminderAfterUpdated of UserImportReminder.FirstReminderAfter.t | UserImportSecondReminderAfterUpdated of UserImportReminder.SecondReminderAfter.t + | PageScriptUpdated of (PageScript.t option * PageScript.location) val handle_event : ?user_uuid:Pool_common.Id.t -> Database.Label.t -> event -> unit Lwt.t val equal_event : event -> event -> bool diff --git a/pool/app/system_event/entity.ml b/pool/app/system_event/entity.ml index 55922cb71..aa71800bd 100644 --- a/pool/app/system_event/entity.ml +++ b/pool/app/system_event/entity.ml @@ -15,6 +15,8 @@ module Job = struct [@printer Utils.ppx_printer "guardiancachecleared"] | I18nPageUpdated [@name "i18npageupdated"] [@printer Utils.ppx_printer "i18npageupdated"] + | PageScriptsUpdated [@name "pagescriptsupdated"] + [@printer Utils.ppx_printer "pagescriptsupdated"] | SmtpAccountUpdated [@name "smtpaccountupdated"] [@printer Utils.ppx_printer "smtpaccountupdated"] | TenantDatabaseReset of Database.Label.t [@name "tenantdatabasereset"] diff --git a/pool/app/system_event/event.ml b/pool/app/system_event/event.ml index 9399c60ae..aee4ec50f 100644 --- a/pool/app/system_event/event.ml +++ b/pool/app/system_event/event.ml @@ -22,6 +22,9 @@ let handle_system_event identifier system_event = | I18nPageUpdated -> let () = I18n.I18nCache.clear () in success_log () + | PageScriptsUpdated -> + let () = Settings.PageScript.clear_cache () in + success_log () | SmtpAccountUpdated -> let () = Email.Service.Cache.clear () in success_log () diff --git a/pool/app/system_event/system_event.mli b/pool/app/system_event/system_event.mli index 8822275b0..c4371609b 100644 --- a/pool/app/system_event/system_event.mli +++ b/pool/app/system_event/system_event.mli @@ -9,6 +9,7 @@ module Job : sig type t = | GuardianCacheCleared | I18nPageUpdated + | PageScriptsUpdated | SmtpAccountUpdated | TenantDatabaseReset of Database.Label.t | TenantCacheCleared diff --git a/pool/cqrs_command/settings_command.ml b/pool/cqrs_command/settings_command.ml index 994235312..67d401e37 100644 --- a/pool/cqrs_command/settings_command.ml +++ b/pool/cqrs_command/settings_command.ml @@ -1,4 +1,7 @@ module Conformist = Pool_conformist + +type validation_set = Guard.ValidationSet.t + open Settings open CCFun.Infix @@ -129,6 +132,53 @@ end = struct let effects = Settings.Guard.Access.update end +module UpdatePageScript : sig + type t = PageScript.t option + + val decode + : PageScript.location + -> (string * string list) list + -> (t, Pool_message.Error.t) result + + val handle + : ?tags:Logs.Tag.set + -> ?system_event_id:System_event.Id.t + -> PageScript.location + -> t + -> (Pool_event.t list, Pool_message.Error.t) result + + val effects : validation_set +end = struct + type t = PageScript.t option + + let schema field = + Conformist.(make Field.[ Conformist.optional @@ PageScript.schema field () ] CCFun.id) + ;; + + let handle ?(tags = Logs.Tag.empty) ?system_event_id placement script = + Logs.info ~src (fun m -> m "Handle command PageScript" ~tags); + Ok + [ Settings.PageScriptUpdated (script, placement) |> Pool_event.settings + ; System_event.(Job.I18nPageUpdated |> create ?id:system_event_id |> created) + |> Pool_event.system_event + ] + ;; + + let decode context = + let field = + let open Pool_message in + let open Settings.PageScript in + match context with + | Head -> Field.PageScriptsHead + | Body -> Field.PageScriptsBody + in + Conformist.decode_and_validate (schema field) + %> CCResult.map_err Pool_message.to_conformist_error + ;; + + let effects = Settings.Guard.Access.update +end + module InactiveUser = struct module DisableAfter : sig include Common.CommandSig with type t = command diff --git a/pool/pool_message/field.ml b/pool/pool_message/field.ml index 9733d99f2..3c5477fa3 100644 --- a/pool/pool_message/field.ml +++ b/pool/pool_message/field.ml @@ -220,6 +220,8 @@ type t = | Override [@name "override"] [@printer go "override"] | Page [@name "page"] [@printer go "page"] | PageCount [@name "page_count"] [@printer go "page_count"] + | PageScriptsHead [@name "page_scripts_head"] [@printer go "page_scripts_head"] + | PageScriptsBody [@name "page_scripts_body"] [@printer go "page_scripts_body"] | Participant [@name "participant"] [@printer go "participant"] | ParticipantCount [@name "participant_count"] [@printer go "participant_count"] | Participants [@name "participants"] [@printer go "participants"] diff --git a/pool/pool_message/field.mli b/pool/pool_message/field.mli index 38030d1cc..bb66bbb93 100644 --- a/pool/pool_message/field.mli +++ b/pool/pool_message/field.mli @@ -189,6 +189,8 @@ type t = | Override | Page | PageCount + | PageScriptsHead + | PageScriptsBody | Participant | ParticipantCount | Participants diff --git a/pool/test/command.ml b/pool/test/command.ml index 671ef73f6..a1f6e2073 100644 --- a/pool/test/command.ml +++ b/pool/test/command.ml @@ -479,6 +479,9 @@ let () = ] ) ; ( "queue" , [ test_case "create delivery report" `Quick Queue_test.create_text_message_dlr ] ) + ; ( "syste m settings" + , [ test_case "update page scripts" `Quick Tenant_settings_test.update_page_scripts + ] ) ; ("time window", Time_window_test.[ test_case "create" `Slow create_timewindow ]) ] ;; diff --git a/pool/test/tenant_settings_test.ml b/pool/test/tenant_settings_test.ml index 073322446..a75257969 100644 --- a/pool/test/tenant_settings_test.ml +++ b/pool/test/tenant_settings_test.ml @@ -354,3 +354,61 @@ let update_gtx_settings _ () = in Lwt.return_unit ;; + +let update_page_scripts () = + let open Settings in + let open CCResult.Infix in + let script = "console.log('hello world')" in + let to_urlencoded ?(script = script) location = + let field = + let open PageScript in + match location with + | Head -> Field.PageScriptsHead + | Body -> Field.PageScriptsBody + in + [ Field.show field, [ script ] ] + in + let open Command.UpdatePageScript in + let system_event_id = System_event.Id.create () in + let cache_event = + System_event.(Job.I18nPageUpdated |> create ~id:system_event_id |> created) + |> Pool_event.system_event + in + let handle location urlencoded = + urlencoded + |> Http_utils.remove_empty_values + |> decode location + >>= handle ~system_event_id location + in + let script = PageScript.of_string script in + (* Head Script *) + let location = PageScript.Head in + let result = location |> to_urlencoded |> handle location in + let expected = + [ Settings.PageScriptUpdated (Some script, location) |> Pool_event.settings + ; cache_event + ] + in + let () = check_events (Ok expected) result in + let result = location |> to_urlencoded ~script:"" |> handle location in + let expected = + [ Settings.PageScriptUpdated (None, location) |> Pool_event.settings; cache_event ] + in + let () = check_events (Ok expected) result in + (* Body Script *) + let location = PageScript.Body in + let result = location |> to_urlencoded |> handle location in + let expected = + [ Settings.PageScriptUpdated (Some script, location) |> Pool_event.settings + ; cache_event + ] + in + let () = check_events (Ok expected) result in + (* Body Script *) + let result = location |> to_urlencoded ~script:"" |> handle location in + let expected = + [ Settings.PageScriptUpdated (None, location) |> Pool_event.settings; cache_event ] + in + let () = check_events (Ok expected) result in + () +;; diff --git a/pool/web/handler/admin_settings.ml b/pool/web/handler/admin_settings.ml index cce2074df..f88eb932f 100644 --- a/pool/web/handler/admin_settings.ml +++ b/pool/web/handler/admin_settings.ml @@ -39,6 +39,7 @@ let show req = let%lwt user_import_second_reminder = Settings.find_user_import_second_reminder_after database_label in + let%lwt page_scripts = Settings.PageScript.find database_label in let text_messages_enabled = Pool_context.Tenant.text_messages_enabled req in let flash_fetcher key = Sihl.Web.Flash.find key req in Page.Admin.Settings.show @@ -52,6 +53,7 @@ let show req = default_text_msg_reminder_lead_time user_import_first_reminder user_import_second_reminder + page_scripts context text_messages_enabled flash_fetcher @@ -66,7 +68,9 @@ let update_settings req = let open Cqrs_command.Settings_command in let lift = Lwt_result.lift in let tags = Pool_context.Logger.Tags.req req in - let%lwt urlencoded = Sihl.Web.Request.to_urlencoded req in + let%lwt urlencoded = + Sihl.Web.Request.to_urlencoded req ||> HttpUtils.remove_empty_values + in let redirect_path = "/admin/settings" in let result { Pool_context.database_label; user; _ } = Utils.Lwt_result.map_error (fun err -> @@ -114,6 +118,14 @@ let update_settings req = | `UserImportSecondReminderAfter -> fun m -> UserImportReminder.UpdateSecondReminder.(m |> decode >>= handle ~tags) |> lift + | `UpdateHeadScripts -> + let location = Settings.PageScript.Head in + fun m -> + UpdatePageScript.(m |> decode location >>= handle ~tags location) |> lift + | `UpdateBodyScripts -> + let location = Settings.PageScript.Body in + fun m -> + UpdatePageScript.(m |> decode location >>= handle ~tags location) |> lift in Sihl.Web.Router.param req "action" |> Settings.action_of_param @@ -153,6 +165,7 @@ module Access : module type of Helpers.Access = struct Command.UserImportReminder.UpdateFirstReminder.effects | `UserImportSecondReminderAfter -> Command.UserImportReminder.UpdateSecondReminder.effects + | `UpdateHeadScripts | `UpdateBodyScripts -> Command.UpdatePageScript.effects in flip Sihl.Web.Router.param "action" %> Settings.action_of_param diff --git a/pool/web/view/layout/layout.ml b/pool/web/view/layout/layout.ml index d36df150e..974ec3db1 100644 --- a/pool/web/view/layout/layout.ml +++ b/pool/web/view/layout/layout.ml @@ -64,7 +64,15 @@ module Tenant = struct let create ?active_navigation - ({ csrf; language; query_parameters; message; user; announcement; _ } as context) + ({ csrf + ; language + ; query_parameters + ; message + ; user + ; announcement + ; database_label + ; _ + } as context) Tenant.{ tenant_languages; tenant } children = @@ -76,9 +84,20 @@ module Tenant = struct | None -> [ `GlobalStylesheet ]) |> CCList.map css_link_tag in + let%lwt head_script, body_script = + let open Settings.PageScript in + let%lwt page_scripts = find database_label in + let make_script = + CCOption.map_or ~default:[] (value %> Unsafe.data %> script %> CCList.return) + in + let head = make_script page_scripts.head in + let body = make_script page_scripts.body in + Lwt.return (head, body) + in let scripts = - (if user_is_admin user then [ `IndexJs; `AdminJs ] else [ `IndexJs ]) - |> CCList.map js_script_tag + body_script + @ ((if user_is_admin user then [ `IndexJs; `AdminJs ] else [ `IndexJs ]) + |> CCList.map js_script_tag) in let message = Message.create message language () in let htmx_notification = div ~a:[ a_id Http_utils.Htmx.notification_id ] [] in @@ -92,7 +111,7 @@ module Tenant = struct tenant.icon |> CCOption.(map (Icon.value %> File.externalized_path %> favicon) %> to_list) in - [ charset; viewport ] @ stylesheets @ favicon + [ charset; viewport ] @ stylesheets @ favicon @ head_script in let%lwt navbar_content = let title = App.create_title query_parameters title_text in diff --git a/pool/web/view/page/page_admin_settings.ml b/pool/web/view/page/page_admin_settings.ml index 45ae1527c..0a8314157 100644 --- a/pool/web/view/page/page_admin_settings.ml +++ b/pool/web/view/page/page_admin_settings.ml @@ -20,6 +20,7 @@ let show default_text_msg_reminder_lead_time user_import_first_reminder user_import_second_reminder + page_scripts Pool_context.{ language; csrf; _ } text_messages_enabled flash_fetcher @@ -323,6 +324,28 @@ let show ] ] in + let hint = Pool_common.(Utils.hint_to_string language I18n.SettingsPageScripts) in + title, columns, Some hint + in + let page_scripts = + let open Settings.PageScript in + let title = "Page scripts" in + let make_form field script action = + form + ~a:(form_attrs action) + [ csrf_element csrf () + ; Component.Input.textarea_element + ?value:(CCOption.map value script) + language + field + ; submit () + ] + in + let columns = + [ make_form Pool_message.Field.PageScriptsHead page_scripts.head `UpdateHeadScripts + ; make_form Pool_message.Field.PageScriptsBody page_scripts.body `UpdateBodyScripts + ] + in title, columns, None in let body_html = @@ -333,6 +356,7 @@ let show ; trigger_profile_update_after_html ; default_lead_time ; user_import_reminder + ; page_scripts ] |> CCList.map (fun (title, columns, hint) -> make_columns title ?hint columns) |> div ~a:[ a_class [ "stack" ] ]