Feature/2243 analytics scripts (#472)

* fix db query

* handle page script cache

* add test case

* add hint

* resolve mr discussion

pool/app/pool_common/entity_i18n.ml

@@ -314,6 +314,7 @@ type hint =
   | SessionReminderLanguageHint
   | SessionReminderLeadTime
   | SettingsNoEmailSuffixes
+  | SettingsPageScripts
   | SignUpCodeHint
   | SignUpForWaitingList
   | SmtpSettingsDefaultFlag

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 \

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 \

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"

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"

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

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

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 =

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

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

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 =

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

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

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

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

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