From 112466c51afc02f0b7b3d258b8b53de026897d33 Mon Sep 17 00:00:00 2001 From: Timo Huber Date: Fri, 4 Oct 2024 11:42:07 +0200 Subject: [PATCH 1/9] add announcement CRUD --- pool/app/announcement/announcement.ml | 6 + pool/app/announcement/announcement.mli | 88 ++++++++++ pool/app/announcement/dune | 13 ++ pool/app/announcement/entity.ml | 84 +++++++++ pool/app/announcement/entity_guard.ml | 32 ++++ pool/app/announcement/event.ml | 20 +++ pool/app/announcement/repo/repo.ml | 76 ++++++++ pool/app/announcement/repo/repo_entity.ml | 49 ++++++ pool/app/custom_field/repo/repo_entity.ml | 12 +- pool/app/pool_common/entity_i18n.ml | 2 + pool/app/pool_common/locales/i18n_de.ml | 2 + pool/app/pool_common/locales/i18n_en.ml | 2 + pool/app/pool_common/locales/locales_de.ml | 8 + pool/app/pool_common/locales/locales_en.ml | 8 + pool/app/pool_common/pool_common.mli | 8 + pool/app/pool_common/repo.ml | 10 ++ .../migrations/migration_202309211305.ml | 1 + .../migrations/migration_202410031211.ml | 42 +++++ pool/app/pool_database/root.ml | 1 + pool/app/role/entity.ml | 2 + pool/cqrs_command/announcement_command.ml | 106 +++++++++++ pool/cqrs_command/dune | 1 + pool/pool_event/dune | 1 + pool/pool_event/pool_event.ml | 5 + pool/pool_message/field.ml | 2 + pool/pool_message/field.mli | 2 + pool/pool_message/pool_message_error.ml | 1 + pool/routes/routes.ml | 10 ++ pool/web/handler/admin_experiments.ml | 1 - pool/web/handler/dune | 1 + pool/web/handler/general.mli | 33 ++++ pool/web/handler/root_announcements.ml | 165 ++++++++++++++++++ pool/web/handler/root_handlers.ml | 1 + pool/web/utils/dune | 1 + pool/web/utils/http_utils_url.ml | 13 ++ pool/web/view/component/component_role.ml | 1 + pool/web/view/layout/layout.ml | 1 + pool/web/view/layout/navigation.ml | 8 + pool/web/view/page/page_root.ml | 1 + pool/web/view/page/page_root_announcement.ml | 144 +++++++++++++++ 40 files changed, 953 insertions(+), 11 deletions(-) create mode 100644 pool/app/announcement/announcement.ml create mode 100644 pool/app/announcement/announcement.mli create mode 100644 pool/app/announcement/dune create mode 100644 pool/app/announcement/entity.ml create mode 100644 pool/app/announcement/entity_guard.ml create mode 100644 pool/app/announcement/event.ml create mode 100644 pool/app/announcement/repo/repo.ml create mode 100644 pool/app/announcement/repo/repo_entity.ml create mode 100644 pool/app/pool_database/migrations/migration_202410031211.ml create mode 100644 pool/cqrs_command/announcement_command.ml create mode 100644 pool/web/handler/general.mli create mode 100644 pool/web/handler/root_announcements.ml create mode 100644 pool/web/view/page/page_root_announcement.ml diff --git a/pool/app/announcement/announcement.ml b/pool/app/announcement/announcement.ml new file mode 100644 index 000000000..79e67bdeb --- /dev/null +++ b/pool/app/announcement/announcement.ml @@ -0,0 +1,6 @@ +include Entity +include Event +include Entity_guard + +let find = Repo.find +let all = Repo.all diff --git a/pool/app/announcement/announcement.mli b/pool/app/announcement/announcement.mli new file mode 100644 index 000000000..207ae4b7b --- /dev/null +++ b/pool/app/announcement/announcement.mli @@ -0,0 +1,88 @@ +module Id : sig + include module type of Pool_common.Id + + val to_common : t -> Pool_common.Id.t +end + +module Text : sig + type t + + val find_opt : Pool_common.Language.t -> t -> string option + val find : Pool_common.Language.t -> t -> string + + val create + : (Pool_common.Language.t * string) list + -> (t, Pool_conformist.error_msg) result +end + +module StartAt : sig + include Pool_model.Base.BaseSig + + val value : t -> Ptime.t + val create : Ptime.t -> t +end + +module EndAt : sig + include Pool_model.Base.BaseSig + + val value : t -> Ptime.t + val create : Ptime.t -> t +end + +type t = + { id : Id.t + ; text : Text.t + ; start_at : StartAt.t option + ; end_at : EndAt.t option + ; created_at : Pool_common.CreatedAt.t + ; updated_at : Pool_common.UpdatedAt.t + } + +val equal : t -> t -> bool +val pp : Format.formatter -> t -> unit +val show : t -> string +val t_of_yojson : Yojson.Safe.t -> t +val yojson_of_t : t -> Yojson.Safe.t +val create : ?id:Id.t -> Text.t -> StartAt.t option -> EndAt.t option -> t + +val find + : Database.Label.t + -> Id.t + -> (t, Pool_message__Pool_message_error.t) result Lwt.t + +val all : ?query:Query.t -> Database.Label.t -> (t list * Query.t) Lwt.t +val column_start : Query.Column.t +val column_end : Query.Column.t +val filterable_by : Query.Filter.human option +val searchable_by : Query.Column.t list +val sortable_by : Query.Column.t list +val default_sort : Query.Sort.t +val default_query : Query.t + +type event = + | Created of t + | Updated of (t * t) + +val handle_event : Database.Label.t -> event -> unit Lwt.t +val equal_event : event -> event -> bool +val pp_event : Format.formatter -> event -> unit + +module Target : sig + val to_authorizable + : ?ctx:(string * string) list + -> t + -> (Guard.Target.t, Pool_message.Error.t) Lwt_result.t + + type t + + val equal : t -> t -> bool + val pp : Format.formatter -> t -> unit + val show : t -> string +end + +module Access : sig + val index : Guard.ValidationSet.t + val create : Guard.ValidationSet.t + val read : Id.t -> Guard.ValidationSet.t + val update : Id.t -> Guard.ValidationSet.t +end diff --git a/pool/app/announcement/dune b/pool/app/announcement/dune new file mode 100644 index 000000000..788cf8941 --- /dev/null +++ b/pool/app/announcement/dune @@ -0,0 +1,13 @@ +(library + (name announcement) + (libraries guard pool_common pool_tenant ptime utils) + (preprocess + (pps + lwt_ppx + ppx_deriving.eq + ppx_deriving.make + ppx_deriving.show + ppx_sexp_conv + ppx_yojson_conv))) + +(include_subdirs unqualified) diff --git a/pool/app/announcement/entity.ml b/pool/app/announcement/entity.ml new file mode 100644 index 000000000..96d5c3d2a --- /dev/null +++ b/pool/app/announcement/entity.ml @@ -0,0 +1,84 @@ +open Ppx_yojson_conv_lib.Yojson_conv +module Language = Pool_common.Language + +let ptime_schema field = + Pool_conformist.schema_decoder + Pool_model.Time.parse_time + Ptime.to_rfc3339 + field +;; + +module Id = struct + include Pool_common.Id +end + +module Text = struct + type name = string [@@deriving eq, show, yojson] + + let value_name n = n + + type t = (Language.t * name) list [@@deriving eq, show, yojson] + + let find_opt lang t = CCList.assoc_opt ~eq:Language.equal lang t + + let find lang t = + find_opt lang t |> CCOption.value ~default:(CCList.hd t |> snd) + ;; + + let create = function + | [] -> Error Pool_message.(Error.AtLeastOneLanguageRequired Field.Text) + | names -> Ok names + ;; +end + +module StartAt = struct + include Pool_model.Base.Ptime + + let create m = m + let schema () = ptime_schema Pool_message.Field.Start +end + +module EndAt = struct + include Pool_model.Base.Ptime + + let create m = m + let schema () = ptime_schema Pool_message.Field.End +end + +type t = + { id : Id.t + ; text : Text.t + ; start_at : StartAt.t option + ; end_at : EndAt.t option + ; created_at : Pool_common.CreatedAt.t + ; updated_at : Pool_common.UpdatedAt.t + } +[@@deriving eq, show, yojson] + +let create ?(id = Id.create ()) tet start_at end_at = + { id + ; text = tet + ; start_at + ; end_at + ; created_at = Pool_common.CreatedAt.create_now () + ; updated_at = Pool_common.UpdatedAt.create_now () + } +;; + +open Pool_message + +let filterable_by = None + +let column_start = + (Field.Start, "pool_announcements.start_at") |> Query.Column.create +;; + +let column_end = (Field.End, "pool_announcements.end_at") |> Query.Column.create +let searchable_by = [] +let sortable_by = [ column_start; column_end ] + +let default_sort = + Query.Sort.{ column = column_start; order = SortOrder.Descending } +;; + +let default_query = Query.create ~sort:default_sort () diff --git a/pool/app/announcement/entity_guard.ml b/pool/app/announcement/entity_guard.ml new file mode 100644 index 000000000..ec79ca6ae --- /dev/null +++ b/pool/app/announcement/entity_guard.ml @@ -0,0 +1,32 @@ +module Target = struct + type t = Entity.t [@@deriving eq, show] + + let to_authorizable ?ctx t = + let open Utils.Lwt_result.Infix in + Guard.Persistence.Target.decorate + ?ctx + (fun Entity.{ id; _ } -> + Guard.Target.create + `Announcement + (id |> Guard.Uuid.target_of Pool_common.Id.value)) + t + >|- Pool_message.Error.authorization + ;; +end + +module Access = struct + open Guard + open ValidationSet + open Permission + + let announcement permission id = + let target_id = id |> Uuid.target_of Pool_common.Id.value in + one_of_tuple (permission, `Announcement, Some target_id) + ;; + + let index_permission = Read + let index = one_of_tuple (index_permission, `Announcement, None) + let create = one_of_tuple (Create, `Announcement, None) + let read = announcement Read + let update = announcement Update +end diff --git a/pool/app/announcement/event.ml b/pool/app/announcement/event.ml new file mode 100644 index 000000000..9e25aec5e --- /dev/null +++ b/pool/app/announcement/event.ml @@ -0,0 +1,20 @@ +open Entity + +type event = + | Created of t + | Updated of (t * t) +[@@deriving eq, show] + +let handle_event pool = + let open Utils.Lwt_result.Infix in + function + | Created m -> + let%lwt () = Repo.insert pool m in + let%lwt () = + Entity_guard.Target.to_authorizable ~ctx:(Database.to_ctx pool) m + ||> Pool_common.Utils.get_or_failwith + ||> fun (_ : Guard.Target.t) -> () + in + Lwt.return_unit + | Updated (_, after) -> Repo.update pool after +;; diff --git a/pool/app/announcement/repo/repo.ml b/pool/app/announcement/repo/repo.ml new file mode 100644 index 000000000..99b5bcfe4 --- /dev/null +++ b/pool/app/announcement/repo/repo.ml @@ -0,0 +1,76 @@ +module Dynparam = Database.Dynparam + +let sql_select_columns = + [ Entity.Id.sql_select_fragment ~field:"pool_announcements.uuid" + ; "pool_announcements.text" + ; "pool_announcements.start_at" + ; "pool_announcements.end_at" + ; "pool_announcements.created_at" + ; "pool_announcements.updated_at" + ] +;; + +let insert_request = + let open Caqti_request.Infix in + {sql| + INSERT INTO pool_announcements ( + uuid, + text, + start_at, + end_at + ) VALUES ( + UNHEX(REPLACE($1, '-', '')), + $2, + $3, + $4 + ) + |sql} + |> Repo_entity.Write.t ->. Caqti_type.unit +;; + +let insert pool = Database.exec pool insert_request + +let update_request = + let open Caqti_request.Infix in + {sql| + UPDATE pool_announcements + SET + text = $2, + start_at = $3, + end_at = $4 + WHERE + uuid = UNHEX(REPLACE($1, '-', '')) + |sql} + |> Repo_entity.Write.t ->. Caqti_type.unit +;; + +let update pool = Database.exec pool update_request + +let find_request_sql ?(count = false) where_fragment = + let columns = + if count then "COUNT(*)" else CCString.concat ", " sql_select_columns + in + Format.asprintf + {sql|SELECT %s FROM pool_announcements %s|sql} + columns + where_fragment +;; + +let find_request = + let open Caqti_request.Infix in + {sql| + WHERE pool_announcements.uuid = UNHEX(REPLACE(?, '-', '')) + |sql} + |> find_request_sql + |> Pool_common.Repo.Id.t ->! Repo_entity.t +;; + +let find pool id = + let open Utils.Lwt_result.Infix in + Database.find_opt pool find_request id + ||> CCOption.to_result Pool_message.(Error.NotFound Field.Announcement) +;; + +let all ?query pool = + Query.collect_and_count pool query ~select:find_request_sql Repo_entity.t +;; diff --git a/pool/app/announcement/repo/repo_entity.ml b/pool/app/announcement/repo/repo_entity.ml new file mode 100644 index 000000000..e68b320f1 --- /dev/null +++ b/pool/app/announcement/repo/repo_entity.ml @@ -0,0 +1,49 @@ +open Entity +open Database.Caqti_encoders + +module Text = struct + include Text + + let t = + let encode = Pool_common.Repo.encode_yojson yojson_of_t in + let decode = + Pool_common.Repo.decode_yojson t_of_yojson Pool_message.Field.Name + in + Caqti_type.(custom ~encode ~decode string) + ;; +end + +let t = + let decode (id, (text, (start_at, (end_at, (created_at, (updated_at, ())))))) = + Ok { id; text; start_at; end_at; created_at; updated_at } + in + let encode _ = Pool_common.Utils.failwith Pool_message.Error.ReadOnlyModel in + let open Schema in + custom + ~encode + ~decode + Caqti_type. + [ Pool_common.Repo.Id.t + ; Text.t + ; option ptime + ; option ptime + ; Pool_common.Repo.CreatedAt.t + ; Pool_common.Repo.UpdatedAt.t + ] +;; + +module Write = struct + let t = + let decode _ = + Pool_common.Utils.failwith Pool_message.Error.WriteOnlyModel + in + let encode m : ('a Data.t, string) result = + Ok Data.[ m.id; m.text; m.start_at; m.end_at ] + in + let open Schema in + custom + ~encode + ~decode + Caqti_type.[ Pool_common.Repo.Id.t; Text.t; option ptime; option ptime ] + ;; +end diff --git a/pool/app/custom_field/repo/repo_entity.ml b/pool/app/custom_field/repo/repo_entity.ml index 11ae90260..c447c45f7 100644 --- a/pool/app/custom_field/repo/repo_entity.ml +++ b/pool/app/custom_field/repo/repo_entity.ml @@ -3,16 +3,8 @@ open Entity open Ppx_yojson_conv_lib.Yojson_conv module Answer = Repo_entity_answer -let encode_yojson of_t t = t |> of_t |> Yojson.Safe.to_string |> CCResult.return - -let decode_yojson t_of_yojson field t = - let read s = s |> Yojson.Safe.from_string |> t_of_yojson in - try Ok (read t) with - | _ -> - Error - (Pool_message.(Error.Invalid field) - |> Pool_common.Utils.error_to_string Language.En) -;; +let encode_yojson = Pool_common.Repo.encode_yojson +let decode_yojson = Pool_common.Repo.decode_yojson type multi_select_answer = SelectOption.Id.t list [@@deriving yojson] diff --git a/pool/app/pool_common/entity_i18n.ml b/pool/app/pool_common/entity_i18n.ml index a39b9aa01..2c2b6d370 100644 --- a/pool/app/pool_common/entity_i18n.ml +++ b/pool/app/pool_common/entity_i18n.ml @@ -2,6 +2,7 @@ type t = | Activity | Address | AdminComment + | AnnouncementsListTitle | AssignmentEditTagsWarning | AssignmentListEmpty | AvailableSpots @@ -116,6 +117,7 @@ type t = type nav_link = | ActorPermissions | Admins + | Announcements | Assignments | ContactInformation | Contacts diff --git a/pool/app/pool_common/locales/i18n_de.ml b/pool/app/pool_common/locales/i18n_de.ml index 82a3e8888..340210f7c 100644 --- a/pool/app/pool_common/locales/i18n_de.ml +++ b/pool/app/pool_common/locales/i18n_de.ml @@ -6,6 +6,7 @@ let to_string = function | Activity -> "Aktivität" | Address -> "Addresse" | AdminComment -> "Administrator Kommentar" + | AnnouncementsListTitle -> "Ankündigungen" | AssignmentEditTagsWarning -> "Bitte beachten Sie, dass durch die Bearbeitung der Anmeldung keine Tags \ zugewiesen oder entfernt werden, die durch die Teilnahme an dieser \ @@ -198,6 +199,7 @@ Sie kommen für mehr Experimente in Frage, umso kompletter Ihr Profil ist.|} let nav_link_to_string = function | ActorPermissions -> "Persönliche Berechtigungen" | Admins -> "Administratoren" + | Announcements -> "Ankündigungen" | Assignments -> "Anmeldungen" | ContactInformation -> "Kontaktangaben" | Contacts -> "Kontakte" diff --git a/pool/app/pool_common/locales/i18n_en.ml b/pool/app/pool_common/locales/i18n_en.ml index a912eedfb..7a46de545 100644 --- a/pool/app/pool_common/locales/i18n_en.ml +++ b/pool/app/pool_common/locales/i18n_en.ml @@ -7,6 +7,7 @@ let to_string = function | Activity -> "activity" | Address -> "address" | AdminComment -> "admin comment" + | AnnouncementsListTitle -> "Announcements" | AssignmentEditTagsWarning -> "Please note that editing the assignment does not assign or remove any \ tags from the contact that may have been assigned by participating in \ @@ -193,6 +194,7 @@ let to_string = function let nav_link_to_string = function | ActorPermissions -> "Personal Permissions" | Admins -> "Admins" + | Announcements -> "Announcements" | Assignments -> "Assignments" | ContactInformation -> "Contact information" | Contacts -> "Contacts" diff --git a/pool/app/pool_common/locales/locales_de.ml b/pool/app/pool_common/locales/locales_de.ml index ee8430474..149e1dc14 100644 --- a/pool/app/pool_common/locales/locales_de.ml +++ b/pool/app/pool_common/locales/locales_de.ml @@ -18,6 +18,7 @@ let rec field_to_string = | AdminInputOnly -> "Eingabe nur durch Admins" | AdminViewOnly -> "Nur für Admins ersichtlich" | AllowUninvitedSignup -> "Einschreiben aller Kontakte erlauben" + | Announcement -> "Ankündigung" | Answer -> "Antwort" | AreaCode -> "Vorwahl" | Argument -> "Argument" @@ -294,6 +295,7 @@ let rec field_to_string = | TermsAndConditions -> "Teilnahmebedingungen" | TermsAndConditionsLastAccepted -> "Teilnahmebedingungen zuletzt akzeptiert" | TestPhoneNumber -> "Testtelefonnummer" + | Text -> "Text" | TextMessage -> "SMS" | TextMessageDlrStatus -> "SMS Status" | TextMessageLeadTime -> "SMS Vorlaufzeit" @@ -454,6 +456,12 @@ let rec error_to_string = | AlreadyStarted -> "Bereits gestarted oder beendet, aktion nicht mehr möglich." | AssignmentAlreadySubmitted -> "Die Teilnahme wurde bereits abgeschlossen." + | AtLeastOneLanguageRequired field -> + field + |> field_to_string + |> CCString.trim + |> Format.asprintf "%s muss in mindestens einer Sprache angegeben werden." + |> CCString.capitalize_ascii | AlreadyInvitedToExperiment names -> Format.asprintf "Die folgenden Kontakte wurden bereits zu diesem Experiment eingeladen: \ diff --git a/pool/app/pool_common/locales/locales_en.ml b/pool/app/pool_common/locales/locales_en.ml index 3f96beec3..dbf0a0a90 100644 --- a/pool/app/pool_common/locales/locales_en.ml +++ b/pool/app/pool_common/locales/locales_en.ml @@ -18,6 +18,7 @@ let rec field_to_string = | AdminInputOnly -> "input only by admins" | AdminViewOnly -> "only visible for admins" | AllowUninvitedSignup -> "Allow registration of all contacts" + | Announcement -> "announcement" | Answer -> "answer" | AreaCode -> "area code" | Argument -> "argument" @@ -291,6 +292,7 @@ let rec field_to_string = | TermsAndConditions -> "terms and conditions" | TermsAndConditionsLastAccepted -> "terms and conditions last accepted at" | TestPhoneNumber -> "test phone number" + | Text -> "text" | TextMessage -> "text message" | TextMessageDlrStatus -> "text message status" | TextMessageLeadTime -> "text message lead time" @@ -439,6 +441,12 @@ let rec error_to_string = "Some assignments have errors. Please resolve them first." | AlreadyStarted -> "Already started or ended, action not possible anymore." | AssignmentAlreadySubmitted -> "This assignment was already submitted." + | AtLeastOneLanguageRequired field -> + field + |> field_to_string + |> CCString.trim + |> Format.asprintf "%s has to be provided in at least one language." + |> CCString.capitalize_ascii | AlreadyInvitedToExperiment names -> Format.asprintf "The following contacts have already been invited to this experiment: %s" diff --git a/pool/app/pool_common/pool_common.mli b/pool/app/pool_common/pool_common.mli index 696dc20ab..43898e8d2 100644 --- a/pool/app/pool_common/pool_common.mli +++ b/pool/app/pool_common/pool_common.mli @@ -184,6 +184,14 @@ module Repo : sig -> ('b -> 'a) -> 'b Caqti_type.t + val encode_yojson : ('a -> Yojson.Safe.t) -> 'a -> (string, 'b) result + + val decode_yojson + : (Yojson.Safe.t -> 'a) + -> Pool_message.Field.t + -> string + -> ('a, string) result + module Model : sig module SelectorType : module type of Repo.Model.SelectorType end diff --git a/pool/app/pool_common/repo.ml b/pool/app/pool_common/repo.ml index c7090a3ff..5d4dbe3c3 100644 --- a/pool/app/pool_common/repo.ml +++ b/pool/app/pool_common/repo.ml @@ -2,6 +2,16 @@ open CCFun open Entity let make_caqti_type = Database.Repo.make_caqti_type +let encode_yojson of_t t = t |> of_t |> Yojson.Safe.to_string |> CCResult.return + +let decode_yojson t_of_yojson field t = + let read s = s |> Yojson.Safe.from_string |> t_of_yojson in + try Ok (read t) with + | _ -> + Error + (Pool_message.(Error.Invalid field) + |> Utils_to_string.error_to_string Language.En) +;; module Model = struct module SelectorType (Core : Pool_model.Base.SelectorCoreTypeSig) = struct diff --git a/pool/app/pool_database/migrations/migration_202309211305.ml b/pool/app/pool_database/migrations/migration_202309211305.ml index 6e4ba6117..8918e539f 100644 --- a/pool/app/pool_database/migrations/migration_202309211305.ml +++ b/pool/app/pool_database/migrations/migration_202309211305.ml @@ -95,6 +95,7 @@ let add_default_guardian_role_permission_root = {sql| INSERT INTO `guardian_role_permissions` (`role`, `permission`, `target_model`) VALUES ('`Operator', 'manage', '`Admin'), + ('`Operator', 'manage', '`Announcement'), ('`Operator', 'manage', '`Assignment'), ('`Operator', 'manage', '`Contact'), ('`Operator', 'manage', '`ContactInfo'), diff --git a/pool/app/pool_database/migrations/migration_202410031211.ml b/pool/app/pool_database/migrations/migration_202410031211.ml new file mode 100644 index 000000000..517de4058 --- /dev/null +++ b/pool/app/pool_database/migrations/migration_202410031211.ml @@ -0,0 +1,42 @@ +let create_pool_announcements_table = + Database.Migration.Step.create + ~label:"create pool_announcements table" + {sql| + CREATE TABLE IF NOT EXISTS pool_announcements ( + id BIGINT UNSIGNED AUTO_INCREMENT, + uuid BINARY(16) NOT NULL, + `text` text, + start_at timestamp, + end_at timestamp, + 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_uuid UNIQUE KEY (uuid) + ) ENGINE=InnoDB DEFAULT CHARSET=utf8mb4 COLLATE=utf8mb4_unicode_ci + |sql} +;; + +let create_pool_announcement_tenants_table = + Database.Migration.Step.create + ~label:"create pool_announcement_tenants table" + {sql| + CREATE TABLE IF NOT EXISTS pool_announcement_tenants ( + id BIGINT UNSIGNED AUTO_INCREMENT, + pool_announcement_uuid BINARY(16) NOT NULL, + pool_tenant_uuid BINARY(16) NOT 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_announchment_tenant UNIQUE KEY (pool_announcement_uuid, pool_tenant_uuid), + CONSTRAINT fk_pool_announcement_uuid FOREIGN KEY (pool_announcement_uuid) REFERENCES pool_announcements(uuid) ON DELETE CASCADE, + CONSTRAINT fk_pool_tenant_uuid FOREIGN KEY (pool_tenant_uuid) REFERENCES pool_tenant(uuid) ON DELETE CASCADE + ) ENGINE=InnoDB DEFAULT CHARSET=utf8mb4 COLLATE=utf8mb4_unicode_ci + |sql} +;; + +let migration () = + Database.Migration.( + empty "202410031211" + |> add_step create_pool_announcements_table + |> add_step create_pool_announcement_tenants_table) +;; diff --git a/pool/app/pool_database/root.ml b/pool/app/pool_database/root.ml index 839bebb4d..84290bbec 100644 --- a/pool/app/pool_database/root.ml +++ b/pool/app/pool_database/root.ml @@ -25,6 +25,7 @@ let steps = ; Migration_202407171415.migration () ; Migration_202408131047.migration () ; Migration_202409021617.migration () + ; Migration_202410031211.migration () ] |> sort in diff --git a/pool/app/role/entity.ml b/pool/app/role/entity.ml index db14b3ada..8f01eaf58 100644 --- a/pool/app/role/entity.ml +++ b/pool/app/role/entity.ml @@ -92,6 +92,7 @@ end module Target = struct type t = [ `Admin + | `Announcement | `Assignment | `Contact | `ContactInfo @@ -139,6 +140,7 @@ module Target = struct Guardian.Utils.decompose_variant_string %> function | "admin", [] -> Ok `Admin + | "announcement", [] -> Ok `Announcement | "assignment", [] -> Ok `Assignment | "contact", [] -> Ok `Contact | "contactinfo", [] -> Ok `ContactInfo diff --git a/pool/cqrs_command/announcement_command.ml b/pool/cqrs_command/announcement_command.ml new file mode 100644 index 000000000..8d1f9d658 --- /dev/null +++ b/pool/cqrs_command/announcement_command.ml @@ -0,0 +1,106 @@ +module Conformist = Pool_conformist +open Announcement + +let src = Logs.Src.create "announcement.cqrs" + +type command = + { start_at : StartAt.t option + ; end_at : EndAt.t option + } + +let command start_at end_at = { start_at; end_at } + +let schema + : ( Conformist.error_msg + , StartAt.t option -> EndAt.t option -> command + , command ) + Conformist.t + = + Pool_conformist.( + make + Field. + [ Conformist.optional @@ StartAt.schema () + ; Conformist.optional @@ EndAt.schema () + ] + command) +;; + +let validate_start_end ~start_at ~end_at = + match start_at, end_at with + | Some start_at, Some end_at + when Ptime.is_later (StartAt.value start_at) ~than:(EndAt.value end_at) -> + Error Pool_message.Error.EndBeforeStart + | _ -> Ok () +;; + +module Create : sig + include Common.CommandSig + + type t = command + + val handle + : ?tags:Logs.Tag.set + -> ?id:Announcement.Id.t + -> (Pool_common.Language.t * string) list + -> t + -> (Pool_event.t list, Pool_message.Error.t) result + + val decode : (string * string list) list -> (t, Pool_message.Error.t) result +end = struct + type t = command + + let handle ?(tags = Logs.Tag.empty) ?id text ({ start_at; end_at } : t) = + let open CCResult in + Logs.info ~src (fun m -> m "Handle command Create" ~tags); + let* () = validate_start_end ~start_at ~end_at in + let* text = Text.create text in + let announcement = create ?id text start_at end_at in + Ok [ Created announcement |> Pool_event.announcement ] + ;; + + let decode data = + Pool_conformist.decode_and_validate schema data + |> CCResult.map_err Pool_message.to_conformist_error + ;; + + let effects = Access.create +end + +module Update : sig + include Common.CommandSig + + type t = command + + val handle + : ?tags:Logs.Tag.set + -> Announcement.t + -> (Pool_common.Language.t * string) list + -> t + -> (Pool_event.t list, Pool_message.Error.t) result + + val decode : (string * string list) list -> (t, Pool_message.Error.t) result + val effects : Id.t -> Guard.ValidationSet.t +end = struct + type t = command + + let handle + ?(tags = Logs.Tag.empty) + announcement + text + ({ start_at; end_at } : t) + = + let open CCResult in + Logs.info ~src (fun m -> m "Handle command Update" ~tags); + let* () = validate_start_end ~start_at ~end_at in + let* text = Text.create text in + let updated = { announcement with text; start_at; end_at } in + Ok [ Updated (announcement, updated) |> Pool_event.announcement ] + ;; + + let decode data = + Pool_conformist.decode_and_validate schema data + |> CCResult.map_err Pool_message.to_conformist_error + ;; + + let effects = Access.update +end diff --git a/pool/cqrs_command/dune b/pool/cqrs_command/dune index b8e34de3a..359dc56f7 100644 --- a/pool/cqrs_command/dune +++ b/pool/cqrs_command/dune @@ -2,6 +2,7 @@ (name cqrs_command) (libraries admin + announcement assignment_job conformist custom_field diff --git a/pool/pool_event/dune b/pool/pool_event/dune index 5bdd5b73b..374428bc5 100644 --- a/pool/pool_event/dune +++ b/pool/pool_event/dune @@ -3,6 +3,7 @@ (name pool_event) (libraries admin + announcement assignment assignment_job contact diff --git a/pool/pool_event/pool_event.ml b/pool/pool_event/pool_event.ml index 26aa9fc76..014fee26e 100644 --- a/pool/pool_event/pool_event.ml +++ b/pool/pool_event/pool_event.ml @@ -2,6 +2,7 @@ type t = | Admin of Admin.event + | Announcement of Announcement.event | Assignment of Assignment.event | AssignmentJob of Assignment_job.event | Contact of Contact.event @@ -31,6 +32,7 @@ type t = [@@deriving eq, show, variants] let admin events = Admin events +let announcement events = Announcement events let assignment events = Assignment events let assignmentjob events = AssignmentJob events let contact events = Contact events @@ -68,6 +70,9 @@ let handle_event ?(tags = Logs.Tag.empty) pool = | Admin event -> info "admin" Admin.pp_event event; Admin.handle_event ~tags pool event + | Announcement event -> + info "announcement" Announcement.pp_event event; + Announcement.handle_event pool event | Assignment event -> info "assignment" Assignment.pp_event event; Assignment.handle_event pool event diff --git a/pool/pool_message/field.ml b/pool/pool_message/field.ml index ccd61730f..d993287bb 100644 --- a/pool/pool_message/field.ml +++ b/pool/pool_message/field.ml @@ -26,6 +26,7 @@ type t = | AdminViewOnly [@name "admin_view_only"] [@printer go "admin_view_only"] | AllowUninvitedSignup [@name "allow_uninvited_signup"] [@printer go "allow_uninvited_signup"] + | Announcement [@name "announcement"] [@printer go "announcement"] | Answer [@name "answer"] [@printer go "answer"] | AreaCode [@name "area_code"] [@printer go "area_code"] | Argument [@name "argument"] [@printer go "argument"] @@ -343,6 +344,7 @@ type t = [@printer go "terms_and_conditions_last_accepted"] | TestPhoneNumber [@name "test_phone_number"] [@printer go "test_phone_number"] + | Text [@name "text"] [@printer go "text"] | TextMessage [@name "text_message"] [@printer go "text_message"] | TextMessageDlrStatus [@name "text_message_dlr_status"] [@printer go "text_message_dlr_mask"] diff --git a/pool/pool_message/field.mli b/pool/pool_message/field.mli index a02f9c980..aa392a0a5 100644 --- a/pool/pool_message/field.mli +++ b/pool/pool_message/field.mli @@ -10,6 +10,7 @@ type t = | AdminInputOnly | AdminViewOnly | AllowUninvitedSignup + | Announcement | Answer | AreaCode | Argument @@ -276,6 +277,7 @@ type t = | TermsAndConditions | TermsAndConditionsLastAccepted | TestPhoneNumber + | Text | TextMessage | TextMessageDlrStatus | TextMessageLeadTime diff --git a/pool/pool_message/pool_message_error.ml b/pool/pool_message/pool_message_error.ml index cca700ebe..5ae50b336 100644 --- a/pool/pool_message/pool_message_error.ml +++ b/pool/pool_message/pool_message_error.ml @@ -16,6 +16,7 @@ type t = | AssignmentIsCanceled | AssignmentIsClosed | AssignmentsHaveErrors + | AtLeastOneLanguageRequired of Field.t | Authorization of string | CannotBeDeleted of Field.t | CannotBeUpdated of Field.t diff --git a/pool/routes/routes.ml b/pool/routes/routes.ml index a44d2790d..298f15f3b 100644 --- a/pool/routes/routes.ml +++ b/pool/routes/routes.ml @@ -972,6 +972,15 @@ module Root = struct ; choose ~scope:(Root |> url_key) specific ] in + let announcements = + let open Announcement in + let specific = [ post "" update; get "edit" edit ] in + [ get "" index + ; post "" create + ; get "new" new_form + ; choose ~scope:Field.(url_key Announcement) specific + ] + in let settings = let smtp = let open Handler.Root.Settings in @@ -997,6 +1006,7 @@ module Root = struct in [ choose [ get "/logout" Login.logout + ; choose ~scope:Field.(show Announcement) announcements ; choose ~scope:"/settings" settings ; choose ~scope:"/user" profile ; choose ~scope:"/tenants" tenants diff --git a/pool/web/handler/admin_experiments.ml b/pool/web/handler/admin_experiments.ml index edf97fea5..ba666ad0f 100644 --- a/pool/web/handler/admin_experiments.ml +++ b/pool/web/handler/admin_experiments.ml @@ -552,7 +552,6 @@ module Access : sig val search : Rock.Middleware.t val message_history : Rock.Middleware.t end = struct - module Field = Field module ExperimentCommand = Cqrs_command.Experiment_command module Guardian = Middleware.Guardian diff --git a/pool/web/handler/dune b/pool/web/handler/dune index 4aa4b9aaa..9a4f10ab7 100644 --- a/pool/web/handler/dune +++ b/pool/web/handler/dune @@ -1,6 +1,7 @@ (library (name handler) (libraries + announcement assignment assignment_job contact diff --git a/pool/web/handler/general.mli b/pool/web/handler/general.mli new file mode 100644 index 000000000..88b4e4caa --- /dev/null +++ b/pool/web/handler/general.mli @@ -0,0 +1,33 @@ +val src : Logs.src + +val user_from_session + : ?cookie_key:string + -> ?secret:string + -> ?key:string + -> Database.Label.t + -> Rock.Request.t + -> Pool_user.t option Lwt.t + +val admin_from_session + : Database.Label.t + -> Rock.Request.t + -> (Admin.t, Pool_message.Error.t) Lwt_result.t + +val create_tenant_layout + : Rock.Request.t + -> ?active_navigation:CCString.t + -> Pool_context.t + -> [< Html_types.div_content_fun > `Div `PCDATA ] Tyxml_html.elt + -> ([> Html_types.html ] Tyxml_html.elt, Pool_message.Error.t) Lwt_result.t + +val create_root_layout + : ?active_navigation:CCString.t + -> Pool_context.t + -> [< Html_types.div_content_fun > `Div `PCDATA ] Tyxml_html.elt + -> [> Html_types.html ] Tyxml_html.elt Lwt.t + +val note + : title:Pool_common.I18n.t + -> body:Pool_common.I18n.t + -> Rock.Request.t + -> Rock.Response.t Lwt.t diff --git a/pool/web/handler/root_announcements.ml b/pool/web/handler/root_announcements.ml new file mode 100644 index 000000000..36e500471 --- /dev/null +++ b/pool/web/handler/root_announcements.ml @@ -0,0 +1,165 @@ +open Utils.Lwt_result.Infix +open Pool_message + +let src = Logs.Src.create "handler.root.announcements" +let active_navigation = "/root/announcements" +let create_layout = General.create_root_layout +let announcement_path = Http_utils.Url.Root.announcement_path + +let announcement_id req = + Http_utils.get_field_router_param req Field.Announcement + |> Announcement.Id.of_string +;; + +let text_from_urlencoded urlencoded = + let open CCOption.Infix in + let open Pool_common.Language in + let sys_languages = all in + sys_languages + |> CCList.filter_map (fun lang -> + let field language = + Format.asprintf "%s[%s]" Field.(show Text) (show language) + in + CCList.assoc_opt ~eq:CCString.equal (field lang) urlencoded + >>= CCList.head_opt + >|= fun text -> lang, text) +;; + +let index req = + let create_layout (_ : Rock.Request.t) ?active_navigation context children = + General.create_root_layout ?active_navigation context children + |> Lwt_result.ok + in + Http_utils.Htmx.handler + ~active_navigation:(announcement_path ()) + ~error_path:"root" + ~query:(module Announcement) + ~create_layout + req + @@ fun (Pool_context.{ database_label; _ } as context) query -> + let%lwt announcements = Announcement.all ~query database_label in + let open Page.Root.Announcement in + (if Http_utils.Htmx.is_hx_request req then list else index) + context + announcements + |> Lwt_result.return +;; + +let form case req = + let result ({ Pool_context.database_label; _ } as context) = + Lwt_result.map_error (fun err -> err, announcement_path ()) + @@ + let flash_fetcher key = Sihl.Web.Flash.find key req in + let sys_languages = Pool_common.Language.all in + let* announcement = + match case with + | `New -> Lwt_result.return None + | `Edit -> + announcement_id req + |> Announcement.find database_label + >|+ CCOption.return + in + Page.Root.Announcement.form + context + ~flash_fetcher + ?announcement + sys_languages + |> create_layout ~active_navigation context + ||> Sihl.Web.Response.of_html + ||> CCResult.return + in + result |> Http_utils.extract_happy_path ~src req +;; + +let new_form = form `New +let edit = form `Edit + +let create req = + let tags = Pool_context.Logger.Tags.req req in + let%lwt urlencoded = + Sihl.Web.Request.to_urlencoded req ||> Http_utils.remove_empty_values + in + let result { Pool_context.database_label; _ } = + Utils.Lwt_result.map_error (fun err -> + ( err + , announcement_path ~suffix:"new" () + , [ Http_utils.urlencoded_to_flash urlencoded ] )) + @@ + let events = + let open CCResult in + let open Cqrs_command.Announcement_command.Create in + let texts = text_from_urlencoded urlencoded in + urlencoded + |> decode + >>= handle ~tags:Logs.Tag.empty texts + |> Lwt_result.lift + in + let handle events = + let%lwt () = + Lwt_list.iter_s (Pool_event.handle_event ~tags database_label) events + in + Http_utils.redirect_to_with_actions + (announcement_path ()) + [ Http_utils.Message.set ~success:[ Success.Created Field.Announcement ] + ] + in + events |>> handle + in + result |> Http_utils.extract_happy_path_with_actions ~src req +;; + +let update req = + let tags = Pool_context.Logger.Tags.req req in + let%lwt urlencoded = + Sihl.Web.Request.to_urlencoded req ||> Http_utils.remove_empty_values + in + let id = announcement_id req in + let result { Pool_context.database_label; _ } = + Utils.Lwt_result.map_error (fun err -> + ( err + , announcement_path ~id ~suffix:"edit" () + , [ Http_utils.urlencoded_to_flash urlencoded ] )) + @@ + let* announcement = Announcement.find database_label id in + let events = + let open CCResult in + let open Cqrs_command.Announcement_command.Update in + let texts = text_from_urlencoded urlencoded in + urlencoded + |> decode + >>= handle ~tags:Logs.Tag.empty announcement texts + |> Lwt_result.lift + in + let handle events = + let%lwt () = + Lwt_list.iter_s (Pool_event.handle_event ~tags database_label) events + in + Http_utils.redirect_to_with_actions + (announcement_path ()) + [ Http_utils.Message.set ~success:[ Success.Updated Field.Announcement ] + ] + in + events |>> handle + in + result |> Http_utils.extract_happy_path_with_actions ~src req +;; + +module Access : sig + include module type of Helpers.Access +end = struct + module Command = Cqrs_command.Announcement_command + module Guardian = Middleware.Guardian + + let announcement_effects = + Guardian.id_effects Announcement.Id.validate Field.Announcement + ;; + + let index = + Announcement.Access.index |> Guardian.validate_admin_entity ~any_id:true + ;; + + let create = Command.Create.effects |> Guardian.validate_admin_entity + let read = announcement_effects Announcement.Access.read + let update = announcement_effects Command.Update.effects + let delete = Guardian.denied +end diff --git a/pool/web/handler/root_handlers.ml b/pool/web/handler/root_handlers.ml index 8bba0ae12..1375d458e 100644 --- a/pool/web/handler/root_handlers.ml +++ b/pool/web/handler/root_handlers.ml @@ -1,3 +1,4 @@ +module Announcement = Root_announcements module Login = Root_login module Profile = Root_user_profile module Settings = Root_settings diff --git a/pool/web/utils/dune b/pool/web/utils/dune index 1de6390b9..532519c76 100644 --- a/pool/web/utils/dune +++ b/pool/web/utils/dune @@ -1,6 +1,7 @@ (library (name http_utils) (libraries + announcement contact experiment logger diff --git a/pool/web/utils/http_utils_url.ml b/pool/web/utils/http_utils_url.ml index 4dff485e2..584fc6470 100644 --- a/pool/web/utils/http_utils_url.ml +++ b/pool/web/utils/http_utils_url.ml @@ -1,3 +1,5 @@ +module Field = Pool_message.Field + let map = CCOption.map let append_opt suffix path = @@ -51,3 +53,14 @@ module Contact = struct |> append_opt suffix ;; end + +module Root = struct + let with_root = Format.asprintf "/root%s" + + let announcement_path ?suffix ?id () = + ("/" ^ Field.(show Announcement)) + |> append_opt (map Announcement.Id.value id) + |> append_opt suffix + |> with_root + ;; +end diff --git a/pool/web/view/component/component_role.ml b/pool/web/view/component/component_role.ml index 6b93e31a9..bfe6604ad 100644 --- a/pool/web/view/component/component_role.ml +++ b/pool/web/view/component/component_role.ml @@ -31,6 +31,7 @@ let create_target_path ?uuid = | `CustomFieldGroup -> Some (build "custom-fields/contact/group" uuid) | `Filter -> Some (build "filter" uuid) | `Tag -> Some (build "settings/tags" uuid) + | `Announcement | `Assignment | `ContactInfo | `ContactDirectMessage diff --git a/pool/web/view/layout/layout.ml b/pool/web/view/layout/layout.ml index a013aee3d..9cf478063 100644 --- a/pool/web/view/layout/layout.ml +++ b/pool/web/view/layout/layout.ml @@ -159,6 +159,7 @@ module Root = struct ; main_tag [ message; content ] ; App.root_footer ; js_script_tag `IndexJs + ; js_script_tag `AdminJs ]) |> Lwt.return ;; diff --git a/pool/web/view/layout/navigation.ml b/pool/web/view/layout/navigation.ml index c5529a998..1a9da47bc 100644 --- a/pool/web/view/layout/navigation.ml +++ b/pool/web/view/layout/navigation.ml @@ -158,6 +158,13 @@ module NavElements = struct single "/root/users" Users (Set Admin.Guard.Access.index) |> NavElement.create in + let announcements = + single + (Http_utils.Url.Root.announcement_path ()) + Announcements + (Set Announcement.Access.index) + |> NavElement.create + in let settings = [ single "/root/settings/smtp" Smtp (Set Email.Guard.Access.Smtp.index) ] |> parent Settings @@ -165,6 +172,7 @@ module NavElements = struct in [ tenants ; users + ; announcements ; settings ; Profile.nav ~prefix:"/root" () ; NavElement.logout ~prefix:"/root" () diff --git a/pool/web/view/page/page_root.ml b/pool/web/view/page/page_root.ml index cc756240f..dda317a92 100644 --- a/pool/web/view/page/page_root.ml +++ b/pool/web/view/page/page_root.ml @@ -1,3 +1,4 @@ +module Announcement = Page_root_announcement module Login = Page_root_login module Tenant = Page_root_tenant module Users = Page_root_users diff --git a/pool/web/view/page/page_root_announcement.ml b/pool/web/view/page/page_root_announcement.ml new file mode 100644 index 000000000..a5fe56f5f --- /dev/null +++ b/pool/web/view/page/page_root_announcement.ml @@ -0,0 +1,144 @@ +open Tyxml.Html +open CCFun.Infix +open Pool_message + +let announcement_path = Http_utils.Url.Root.announcement_path +let field_to_string = Pool_common.Utils.field_to_string_capitalized + +let list { Pool_context.language; _ } (annoucements, query) = + let open Announcement in + let url = announcement_path () |> Uri.of_string in + let data_table = Component.DataTable.create_meta url query language in + let create_btn = + let open Component in + announcement_path ~suffix:"new" () + |> Input.link_as_button + ~style:`Success + ~icon:Icon.Add + ~control:(language, Control.Add None) + in + let cols = + [ `custom (txt (field_to_string language Field.Text)) + ; `column column_start + ; `column column_end + ; `custom create_btn + ] + in + let row ({ id; start_at; end_at; text; _ } : t) = + let open CCOption in + let edit_btn = + let open Component in + announcement_path ~id ~suffix:"edit" () + |> Input.link_as_button ~style:`Primary ~icon:Icon.Create + in + let format_time = Utils.Ptime.formatted_date_time in + [ Text.find language text |> Unsafe.data + ; start_at |> map_or ~default:"" (StartAt.value %> format_time) |> txt + ; end_at |> map_or ~default:"" (EndAt.value %> format_time) |> txt + ; edit_btn + ] + |> CCList.map (CCList.return %> td) + |> tr + in + Component.DataTable.make + ~target_id:"announcements-list" + ~cols + ~row + data_table + annoucements +;; + +let index (Pool_context.{ language; _ } as context) announcements = + let open Pool_common in + div + ~a:[ a_class [ "trim"; "safety-margin" ] ] + [ h1 + ~a:[ a_class [ "heading-1" ] ] + [ txt (Utils.text_to_string language I18n.AnnouncementsListTitle) ] + ; list context announcements + ] +;; + +let form + { Pool_context.csrf; language; _ } + ?announcement + ?(flash_fetcher : (string -> string option) option) + system_languages + = + let open Component in + let open Announcement in + let open CCOption.Infix in + let action = + match announcement with + | None -> announcement_path () + | Some announcement -> announcement_path ~id:announcement.id () + in + let title = + let field = Some Field.Announcement in + match CCOption.is_some announcement with + | false -> Control.Create field + | true -> Control.Update field + in + let date_input field value = + Input.date_time_picker_element + ~min_value:(Ptime_clock.now ()) + ?flash_fetcher + ?value + language + field + in + let text_inputs = + system_languages + |> CCList.map (fun lang -> + let name = + Format.asprintf + "%s[%s]" + Field.(show Text) + (Pool_common.Language.show lang) + in + let value = + let open CCOption in + bind flash_fetcher (fun flash_fetcher -> flash_fetcher name) + <+> (announcement >>= fun { text; _ } -> Text.find_opt lang text) + in + div + ~a:[ a_class [ "form-group" ] ] + [ label ~a:[ a_label_for name ] [ txt (Pool_common.Language.show lang) ] + ; textarea + ~a:[ a_class [ "rich-text" ]; a_name name; a_id name ] + (txt (CCOption.value value ~default:"")) + ]) + in + div + ~a:[ a_class [ "trim"; "safety-margin" ] ] + [ h1 [ txt (Pool_common.Utils.control_to_string language title) ] + ; form + ~a: + [ a_method `Post + ; a_action (Sihl.Web.externalize_path action) + ; a_class [ "stack" ] + ; a_user_data "detect-unsaved-changes" "" + ] + Input. + [ csrf_element csrf () + ; div + ~a:[ a_class [ "grid-col-2" ] ] + [ date_input + Field.Start + (announcement + >>= fun { start_at; _ } -> start_at >|= StartAt.value) + ; date_input + Field.End + (announcement >>= fun { end_at; _ } -> end_at >|= EndAt.value) + ; div + ~a:[ a_class [ "full-width" ] ] + [ h2 [ txt (field_to_string language Field.Text) ] + ; div ~a:[ a_class [ "stack" ] ] text_inputs + ] + ; div + ~a:[ a_class [ "full-width"; "flexrow"; "justify-end" ] ] + [ submit_element language title () ] + ] + ] + ] +;; From ba3fc6b79ae3da4017f8effd07c68a115a60e5db Mon Sep 17 00:00:00 2001 From: Timo Huber Date: Fri, 4 Oct 2024 13:25:15 +0200 Subject: [PATCH 2/9] allow selection of tenants --- pool/app/announcement/announcement.ml | 1 + pool/app/announcement/announcement.mli | 12 ++- pool/app/announcement/entity.ml | 2 + pool/app/announcement/event.ml | 8 +- pool/app/announcement/repo/repo.ml | 104 ++++++++++++++++++- pool/app/pool_common/entity_i18n.ml | 1 + pool/app/pool_common/locales/i18n_de.ml | 2 + pool/app/pool_common/locales/i18n_en.ml | 2 + pool/app/pool_tenant/pool_tenant.ml | 4 + pool/app/pool_tenant/pool_tenant.mli | 6 ++ pool/cqrs_command/announcement_command.ml | 15 ++- pool/web/handler/root_announcements.ml | 25 ++++- pool/web/view/page/page_root_announcement.ml | 40 +++++++ 13 files changed, 207 insertions(+), 15 deletions(-) diff --git a/pool/app/announcement/announcement.ml b/pool/app/announcement/announcement.ml index 79e67bdeb..14884eaf5 100644 --- a/pool/app/announcement/announcement.ml +++ b/pool/app/announcement/announcement.ml @@ -4,3 +4,4 @@ include Entity_guard let find = Repo.find let all = Repo.all +let find_admin = Repo.find_admin diff --git a/pool/app/announcement/announcement.mli b/pool/app/announcement/announcement.mli index 207ae4b7b..3431cbde0 100644 --- a/pool/app/announcement/announcement.mli +++ b/pool/app/announcement/announcement.mli @@ -45,12 +45,20 @@ val t_of_yojson : Yojson.Safe.t -> t val yojson_of_t : t -> Yojson.Safe.t val create : ?id:Id.t -> Text.t -> StartAt.t option -> EndAt.t option -> t +type admin = t * Pool_tenant.t list + val find : Database.Label.t -> Id.t -> (t, Pool_message__Pool_message_error.t) result Lwt.t val all : ?query:Query.t -> Database.Label.t -> (t list * Query.t) Lwt.t + +val find_admin + : Database.Label.t + -> Id.t + -> (admin, Pool_message.Error.t) Lwt_result.t + val column_start : Query.Column.t val column_end : Query.Column.t val filterable_by : Query.Filter.human option @@ -60,8 +68,8 @@ val default_sort : Query.Sort.t val default_query : Query.t type event = - | Created of t - | Updated of (t * t) + | Created of (t * Pool_tenant.Id.t list) + | Updated of (t * Pool_tenant.Id.t list) val handle_event : Database.Label.t -> event -> unit Lwt.t val equal_event : event -> event -> bool diff --git a/pool/app/announcement/entity.ml b/pool/app/announcement/entity.ml index 96d5c3d2a..f9cc6d99b 100644 --- a/pool/app/announcement/entity.ml +++ b/pool/app/announcement/entity.ml @@ -65,6 +65,8 @@ let create ?(id = Id.create ()) tet start_at end_at = } ;; +type admin = t * Pool_tenant.t list [@@deriving eq, show] + open Pool_message let filterable_by = None diff --git a/pool/app/announcement/event.ml b/pool/app/announcement/event.ml index 9e25aec5e..18b6e0ad9 100644 --- a/pool/app/announcement/event.ml +++ b/pool/app/announcement/event.ml @@ -1,8 +1,8 @@ open Entity type event = - | Created of t - | Updated of (t * t) + | Created of (t * Pool_tenant.Id.t list) + | Updated of (t * Pool_tenant.Id.t list) [@@deriving eq, show] let handle_event pool = @@ -11,10 +11,10 @@ let handle_event pool = | Created m -> let%lwt () = Repo.insert pool m in let%lwt () = - Entity_guard.Target.to_authorizable ~ctx:(Database.to_ctx pool) m + Entity_guard.Target.to_authorizable ~ctx:(Database.to_ctx pool) (fst m) ||> Pool_common.Utils.get_or_failwith ||> fun (_ : Guard.Target.t) -> () in Lwt.return_unit - | Updated (_, after) -> Repo.update pool after + | Updated m -> Repo.update pool m ;; diff --git a/pool/app/announcement/repo/repo.ml b/pool/app/announcement/repo/repo.ml index 99b5bcfe4..d33d02920 100644 --- a/pool/app/announcement/repo/repo.ml +++ b/pool/app/announcement/repo/repo.ml @@ -10,6 +10,93 @@ let sql_select_columns = ] ;; +module TenantMapping = struct + open Caqti_request.Infix + + let caqti_id = Pool_common.Repo.Id.t + let caqti_tenant_id = Pool_tenant.Repo.Id.t + + let delete_existing_request tenant_ids = + CCList.mapi + (fun i _ -> Format.asprintf "UNHEX(REPLACE($%n, '-', ''))" (i + 2)) + tenant_ids + |> CCString.concat "," + |> Format.asprintf + {sql| + DELETE FROM pool_announcement_tenants + WHERE pool_announcement_uuid = UNHEX(REPLACE($1, '-', '')) + AND pool_tenant_uuid NOT IN ( %s ) + |sql} + ;; + + let delete_all_existing_request = + {sql| + DELETE FROM pool_announcement_tenants + WHERE pool_announcement_uuid = UNHEX(REPLACE($1, '-', '')) + |sql} + |> caqti_id ->. Caqti_type.unit + ;; + + let insert_request = + let open Caqti_request.Infix in + {sql| + INSERT INTO pool_announcement_tenants ( + pool_announcement_uuid, + pool_tenant_uuid + ) VALUES ( + UNHEX(REPLACE($1, '-', '')), + UNHEX(REPLACE($2, '-', '')) + ) ON DUPLICATE KEY UPDATE + updated_at = NOW() + |sql} + |> Caqti_type.(t2 caqti_id caqti_tenant_id ->. Caqti_type.unit) + ;; + + let insert pool { Entity.id; _ } tenant_ids = + match tenant_ids with + | [] -> Database.exec pool delete_all_existing_request id + | tenant_ids -> + let open Dynparam in + let dyn = + let init = empty |> add caqti_id id in + CCList.fold_left + (fun dyn id -> add caqti_tenant_id id dyn) + init + tenant_ids + in + let (Dynparam.Pack (pt, pv)) = dyn in + let delete_request = + delete_existing_request tenant_ids |> pt ->. Caqti_type.unit + in + let%lwt () = Database.exec pool delete_request pv in + tenant_ids + |> Lwt_list.iter_s (fun tenant_id -> + Database.exec pool insert_request (id, tenant_id)) + ;; + + let tenant_uuid_request = + let open Caqti_request.Infix in + Format.asprintf + {sql| + SELECT + %s + FROM + pool_announcement_tenants + WHERE + pool_announcement_uuid = UNHEX(REPLACE($1, '-', '')) + |sql} + (Entity.Id.sql_select_fragment ~field:"pool_tenant_uuid") + |> caqti_id ->* caqti_tenant_id + ;; + + let find_tenants_by_announcement pool announcement_id = + let open Utils.Lwt_result.Infix in + Database.collect pool tenant_uuid_request announcement_id + >|> Lwt_list.map_s Pool_tenant.find + ||> CCList.all_ok + ;; +end + let insert_request = let open Caqti_request.Infix in {sql| @@ -28,7 +115,10 @@ let insert_request = |> Repo_entity.Write.t ->. Caqti_type.unit ;; -let insert pool = Database.exec pool insert_request +let insert pool (announcement, tenant_ids) = + let%lwt () = Database.exec pool insert_request announcement in + TenantMapping.insert pool announcement tenant_ids +;; let update_request = let open Caqti_request.Infix in @@ -44,7 +134,10 @@ let update_request = |> Repo_entity.Write.t ->. Caqti_type.unit ;; -let update pool = Database.exec pool update_request +let update pool (announcement, tenant_ids) = + let%lwt () = Database.exec pool update_request announcement in + TenantMapping.insert pool announcement tenant_ids +;; let find_request_sql ?(count = false) where_fragment = let columns = @@ -74,3 +167,10 @@ let find pool id = let all ?query pool = Query.collect_and_count pool query ~select:find_request_sql Repo_entity.t ;; + +let find_admin pool id = + let open Utils.Lwt_result.Infix in + let* announcement = find pool id in + let* tenants = TenantMapping.find_tenants_by_announcement pool id in + Lwt_result.return (announcement, tenants) +;; diff --git a/pool/app/pool_common/entity_i18n.ml b/pool/app/pool_common/entity_i18n.ml index 2c2b6d370..e3946dc93 100644 --- a/pool/app/pool_common/entity_i18n.ml +++ b/pool/app/pool_common/entity_i18n.ml @@ -3,6 +3,7 @@ type t = | Address | AdminComment | AnnouncementsListTitle + | AnnouncementsTenantSelect | AssignmentEditTagsWarning | AssignmentListEmpty | AvailableSpots diff --git a/pool/app/pool_common/locales/i18n_de.ml b/pool/app/pool_common/locales/i18n_de.ml index 340210f7c..f26fae7bf 100644 --- a/pool/app/pool_common/locales/i18n_de.ml +++ b/pool/app/pool_common/locales/i18n_de.ml @@ -7,6 +7,8 @@ let to_string = function | Address -> "Addresse" | AdminComment -> "Administrator Kommentar" | AnnouncementsListTitle -> "Ankündigungen" + | AnnouncementsTenantSelect -> + "Wählen Sie, auf welchen Tenants die Ankündigung angezeigt werden soll." | AssignmentEditTagsWarning -> "Bitte beachten Sie, dass durch die Bearbeitung der Anmeldung keine Tags \ zugewiesen oder entfernt werden, die durch die Teilnahme an dieser \ diff --git a/pool/app/pool_common/locales/i18n_en.ml b/pool/app/pool_common/locales/i18n_en.ml index 7a46de545..4633b31d6 100644 --- a/pool/app/pool_common/locales/i18n_en.ml +++ b/pool/app/pool_common/locales/i18n_en.ml @@ -8,6 +8,8 @@ let to_string = function | Address -> "address" | AdminComment -> "admin comment" | AnnouncementsListTitle -> "Announcements" + | AnnouncementsTenantSelect -> + "Select on which tenants the announcement should be displayed." | AssignmentEditTagsWarning -> "Please note that editing the assignment does not assign or remove any \ tags from the contact that may have been assigned by participating in \ diff --git a/pool/app/pool_tenant/pool_tenant.ml b/pool/app/pool_tenant/pool_tenant.ml index 7a8071c0d..da4a0c4c4 100644 --- a/pool/app/pool_tenant/pool_tenant.ml +++ b/pool/app/pool_tenant/pool_tenant.ml @@ -29,3 +29,7 @@ let create_public_url pool_url = ;; let clear_cache = Repo.Cache.clear + +module Repo = struct + module Id = Repo_entity.Id +end diff --git a/pool/app/pool_tenant/pool_tenant.mli b/pool/app/pool_tenant/pool_tenant.mli index 86c25400b..6a30c7b0e 100644 --- a/pool/app/pool_tenant/pool_tenant.mli +++ b/pool/app/pool_tenant/pool_tenant.mli @@ -200,6 +200,12 @@ val find_gtx_api_key_and_url_by_label val create_public_url : Url.t -> string -> string val clear_cache : unit -> unit +module Repo : sig + module Id : sig + val t : Id.t Caqti_type.t + end +end + type handle_list_recruiters = unit -> Pool_user.t list Lwt.t type handle_list_tenants = unit -> t list Lwt.t type logo_mappings = LogoMapping.Write.t list diff --git a/pool/cqrs_command/announcement_command.ml b/pool/cqrs_command/announcement_command.ml index 8d1f9d658..c0fe20c24 100644 --- a/pool/cqrs_command/announcement_command.ml +++ b/pool/cqrs_command/announcement_command.ml @@ -42,6 +42,7 @@ module Create : sig : ?tags:Logs.Tag.set -> ?id:Announcement.Id.t -> (Pool_common.Language.t * string) list + -> Pool_tenant.Id.t list -> t -> (Pool_event.t list, Pool_message.Error.t) result @@ -49,13 +50,19 @@ module Create : sig end = struct type t = command - let handle ?(tags = Logs.Tag.empty) ?id text ({ start_at; end_at } : t) = + let handle + ?(tags = Logs.Tag.empty) + ?id + text + tenant_ids + ({ start_at; end_at } : t) + = let open CCResult in Logs.info ~src (fun m -> m "Handle command Create" ~tags); let* () = validate_start_end ~start_at ~end_at in let* text = Text.create text in let announcement = create ?id text start_at end_at in - Ok [ Created announcement |> Pool_event.announcement ] + Ok [ Created (announcement, tenant_ids) |> Pool_event.announcement ] ;; let decode data = @@ -75,6 +82,7 @@ module Update : sig : ?tags:Logs.Tag.set -> Announcement.t -> (Pool_common.Language.t * string) list + -> Pool_tenant.Id.t list -> t -> (Pool_event.t list, Pool_message.Error.t) result @@ -87,6 +95,7 @@ end = struct ?(tags = Logs.Tag.empty) announcement text + tenant_ids ({ start_at; end_at } : t) = let open CCResult in @@ -94,7 +103,7 @@ end = struct let* () = validate_start_end ~start_at ~end_at in let* text = Text.create text in let updated = { announcement with text; start_at; end_at } in - Ok [ Updated (announcement, updated) |> Pool_event.announcement ] + Ok [ Updated (updated, tenant_ids) |> Pool_event.announcement ] ;; let decode data = diff --git a/pool/web/handler/root_announcements.ml b/pool/web/handler/root_announcements.ml index 36e500471..5982f81e8 100644 --- a/pool/web/handler/root_announcements.ml +++ b/pool/web/handler/root_announcements.ml @@ -25,6 +25,19 @@ let text_from_urlencoded urlencoded = >|= fun text -> lang, text) ;; +let selected_tenants_from_urlencoded req = + let open CCList in + let open Pool_tenant in + let%lwt tenants = find_all () in + let%lwt selected_tenants = + Sihl.Web.Request.urlencoded_list Field.(array_key Tenant) req + in + tenants + |> filter_map (fun { id; _ } -> + if mem (Id.value id) selected_tenants then Some id else None) + |> Lwt.return +;; + let index req = let create_layout (_ : Rock.Request.t) ?active_navigation context children = General.create_root_layout ?active_navigation context children @@ -51,19 +64,21 @@ let form case req = @@ let flash_fetcher key = Sihl.Web.Flash.find key req in let sys_languages = Pool_common.Language.all in + let%lwt tenants = Pool_tenant.find_all () in let* announcement = match case with | `New -> Lwt_result.return None | `Edit -> announcement_id req - |> Announcement.find database_label + |> Announcement.find_admin database_label >|+ CCOption.return in Page.Root.Announcement.form context + tenants + sys_languages ~flash_fetcher ?announcement - sys_languages |> create_layout ~active_navigation context ||> Sihl.Web.Response.of_html ||> CCResult.return @@ -89,9 +104,10 @@ let create req = let open CCResult in let open Cqrs_command.Announcement_command.Create in let texts = text_from_urlencoded urlencoded in + let%lwt tenant_ids = selected_tenants_from_urlencoded req in urlencoded |> decode - >>= handle ~tags:Logs.Tag.empty texts + >>= handle ~tags:Logs.Tag.empty texts tenant_ids |> Lwt_result.lift in let handle events = @@ -125,9 +141,10 @@ let update req = let open CCResult in let open Cqrs_command.Announcement_command.Update in let texts = text_from_urlencoded urlencoded in + let%lwt tenant_ids = selected_tenants_from_urlencoded req in urlencoded |> decode - >>= handle ~tags:Logs.Tag.empty announcement texts + >>= handle ~tags:Logs.Tag.empty announcement texts tenant_ids |> Lwt_result.lift in let handle events = diff --git a/pool/web/view/page/page_root_announcement.ml b/pool/web/view/page/page_root_announcement.ml index a5fe56f5f..0b6fb62f4 100644 --- a/pool/web/view/page/page_root_announcement.ml +++ b/pool/web/view/page/page_root_announcement.ml @@ -63,11 +63,17 @@ let form { Pool_context.csrf; language; _ } ?announcement ?(flash_fetcher : (string -> string option) option) + available_tenants system_languages = let open Component in let open Announcement in let open CCOption.Infix in + let announcement, tenants = + match announcement with + | Some (announcement, tenants) -> Some announcement, Some tenants + | None -> None, None + in let action = match announcement with | None -> announcement_path () @@ -109,6 +115,39 @@ let form (txt (CCOption.value value ~default:"")) ]) in + let tenant_select = + let open Pool_tenant in + let name = Field.(array_key Tenant) in + let checkboxes = + available_tenants + |> CCList.map (fun { id; title; _ } -> + let checked = + let open CCOption in + tenants + >|= CCList.find_opt (fun tenant -> + Pool_tenant.Id.equal id tenant.Pool_tenant.id) + |> map_or ~default:false is_some + in + let id = Id.value id in + div + [ input + ~a: + ([ a_name name; a_id id; a_value id; a_input_type `Checkbox ] + @ if checked then [ a_checked () ] else []) + () + ; label ~a:[ a_label_for id ] [ txt (Title.value title) ] + ]) + in + div + ~a:[ a_class [ "form-group" ] ] + [ p + [ txt + Pool_common.( + Utils.text_to_string language I18n.AnnouncementsTenantSelect) + ] + ; div ~a:[ a_class [ "input-group" ] ] checkboxes + ] + in div ~a:[ a_class [ "trim"; "safety-margin" ] ] [ h1 [ txt (Pool_common.Utils.control_to_string language title) ] @@ -135,6 +174,7 @@ let form [ h2 [ txt (field_to_string language Field.Text) ] ; div ~a:[ a_class [ "stack" ] ] text_inputs ] + ; tenant_select ; div ~a:[ a_class [ "full-width"; "flexrow"; "justify-end" ] ] [ submit_element language title () ] From 054dfe60884142b95c2dd1f0f63f2c4a35aa44f6 Mon Sep 17 00:00:00 2001 From: Timo Huber Date: Wed, 9 Oct 2024 17:07:01 +0200 Subject: [PATCH 3/9] add option to display to contacts and admin --- pool/app/announcement/announcement.mli | 34 +++++++++++++- pool/app/announcement/entity.ml | 29 +++++++++++- pool/app/announcement/repo/repo.ml | 14 ++++-- pool/app/announcement/repo/repo_entity.ml | 41 +++++++++++++++-- pool/app/pool_common/locales/locales_de.ml | 7 +++ pool/app/pool_common/locales/locales_en.ml | 7 +++ .../migrations/migration_202410031211.ml | 2 + pool/cqrs_command/announcement_command.ml | 46 ++++++++++++++----- pool/pool_message/field.ml | 2 + pool/pool_message/field.mli | 2 + pool/pool_message/pool_message_error.ml | 1 + pool/pool_model/base.ml | 5 +- pool/web/view/page/page_root_announcement.ml | 38 ++++++++++++++- 13 files changed, 205 insertions(+), 23 deletions(-) diff --git a/pool/app/announcement/announcement.mli b/pool/app/announcement/announcement.mli index 3431cbde0..f6eb07108 100644 --- a/pool/app/announcement/announcement.mli +++ b/pool/app/announcement/announcement.mli @@ -29,11 +29,35 @@ module EndAt : sig val create : Ptime.t -> t end +module ShowToAdmins : sig + include Pool_model.Base.BooleanSig + + val schema + : ?default:t + -> unit + -> (Pool_message.Error.t, t) Pool_conformist.Field.t + + val init : t +end + +module ShowToContacts : sig + include Pool_model.Base.BooleanSig + + val schema + : ?default:t + -> unit + -> (Pool_message.Error.t, t) Pool_conformist.Field.t + + val init : t +end + type t = { id : Id.t ; text : Text.t ; start_at : StartAt.t option ; end_at : EndAt.t option + ; show_to_admins : ShowToAdmins.t + ; show_to_contacts : ShowToContacts.t ; created_at : Pool_common.CreatedAt.t ; updated_at : Pool_common.UpdatedAt.t } @@ -43,7 +67,15 @@ val pp : Format.formatter -> t -> unit val show : t -> string val t_of_yojson : Yojson.Safe.t -> t val yojson_of_t : t -> Yojson.Safe.t -val create : ?id:Id.t -> Text.t -> StartAt.t option -> EndAt.t option -> t + +val create + : ?id:Id.t + -> Text.t + -> StartAt.t option + -> EndAt.t option + -> ShowToAdmins.t + -> ShowToContacts.t + -> t type admin = t * Pool_tenant.t list diff --git a/pool/app/announcement/entity.ml b/pool/app/announcement/entity.ml index f9cc6d99b..33cc5417c 100644 --- a/pool/app/announcement/entity.ml +++ b/pool/app/announcement/entity.ml @@ -45,21 +45,48 @@ module EndAt = struct let schema () = ptime_schema Pool_message.Field.End end +module ShowToAdmins = struct + include Pool_model.Base.Boolean + + let init = false + let field = Pool_message.Field.ShowToAdmins + let schema ?default = schema ?default field +end + +module ShowToContacts = struct + include Pool_model.Base.Boolean + + let init = false + let field = Pool_message.Field.ShowToContacts + let schema ?default = schema ?default field +end + type t = { id : Id.t ; text : Text.t ; start_at : StartAt.t option ; end_at : EndAt.t option + ; show_to_admins : ShowToAdmins.t + ; show_to_contacts : ShowToContacts.t ; created_at : Pool_common.CreatedAt.t ; updated_at : Pool_common.UpdatedAt.t } [@@deriving eq, show, yojson] -let create ?(id = Id.create ()) tet start_at end_at = +let create + ?(id = Id.create ()) + tet + start_at + end_at + show_to_admins + show_to_contacts + = { id ; text = tet ; start_at ; end_at + ; show_to_admins + ; show_to_contacts ; created_at = Pool_common.CreatedAt.create_now () ; updated_at = Pool_common.UpdatedAt.create_now () } diff --git a/pool/app/announcement/repo/repo.ml b/pool/app/announcement/repo/repo.ml index d33d02920..ec6fdfe2d 100644 --- a/pool/app/announcement/repo/repo.ml +++ b/pool/app/announcement/repo/repo.ml @@ -5,6 +5,8 @@ let sql_select_columns = ; "pool_announcements.text" ; "pool_announcements.start_at" ; "pool_announcements.end_at" + ; "pool_announcements.show_to_admins" + ; "pool_announcements.show_to_contacts" ; "pool_announcements.created_at" ; "pool_announcements.updated_at" ] @@ -104,12 +106,16 @@ let insert_request = uuid, text, start_at, - end_at + end_at, + show_to_admins, + show_to_contacts ) VALUES ( UNHEX(REPLACE($1, '-', '')), $2, $3, - $4 + $4, + $5, + $6 ) |sql} |> Repo_entity.Write.t ->. Caqti_type.unit @@ -127,7 +133,9 @@ let update_request = SET text = $2, start_at = $3, - end_at = $4 + end_at = $4, + show_to_admins = $5, + show_to_contacts = $6 WHERE uuid = UNHEX(REPLACE($1, '-', '')) |sql} diff --git a/pool/app/announcement/repo/repo_entity.ml b/pool/app/announcement/repo/repo_entity.ml index e68b320f1..cc39c49b4 100644 --- a/pool/app/announcement/repo/repo_entity.ml +++ b/pool/app/announcement/repo/repo_entity.ml @@ -14,8 +14,24 @@ module Text = struct end let t = - let decode (id, (text, (start_at, (end_at, (created_at, (updated_at, ())))))) = - Ok { id; text; start_at; end_at; created_at; updated_at } + let decode + ( id + , ( text + , ( start_at + , ( end_at + , (show_to_admins, (show_to_contacts, (created_at, (updated_at, ())))) + ) ) ) ) + = + Ok + { id + ; text + ; start_at + ; end_at + ; show_to_admins + ; show_to_contacts + ; created_at + ; updated_at + } in let encode _ = Pool_common.Utils.failwith Pool_message.Error.ReadOnlyModel in let open Schema in @@ -27,6 +43,8 @@ let t = ; Text.t ; option ptime ; option ptime + ; bool + ; bool ; Pool_common.Repo.CreatedAt.t ; Pool_common.Repo.UpdatedAt.t ] @@ -38,12 +56,27 @@ module Write = struct Pool_common.Utils.failwith Pool_message.Error.WriteOnlyModel in let encode m : ('a Data.t, string) result = - Ok Data.[ m.id; m.text; m.start_at; m.end_at ] + Ok + Data. + [ m.id + ; m.text + ; m.start_at + ; m.end_at + ; m.show_to_admins + ; m.show_to_contacts + ] in let open Schema in custom ~encode ~decode - Caqti_type.[ Pool_common.Repo.Id.t; Text.t; option ptime; option ptime ] + Caqti_type. + [ Pool_common.Repo.Id.t + ; Text.t + ; option ptime + ; option ptime + ; bool + ; bool + ] ;; end diff --git a/pool/app/pool_common/locales/locales_de.ml b/pool/app/pool_common/locales/locales_de.ml index 149e1dc14..15fb7f6c8 100644 --- a/pool/app/pool_common/locales/locales_de.ml +++ b/pool/app/pool_common/locales/locales_de.ml @@ -256,6 +256,8 @@ let rec field_to_string = | Setting -> "Einstellung" | Settings -> "Einstellungen" | ShowUpCount -> "Anwesende" + | ShowToAdmins -> "Den Administratoren anzeigen" + | ShowToContacts -> "Den Kontakten anzeigen" | ShowExteralDataIdLinks -> "Link zu externen Datenidentifikatoren anzeigen" | SignedUpAt -> "Eingeschrieben am" | SignUpCount -> "Neuregistrierungen" @@ -462,6 +464,11 @@ let rec error_to_string = |> CCString.trim |> Format.asprintf "%s muss in mindestens einer Sprache angegeben werden." |> CCString.capitalize_ascii + | AtLeastOneSelected (field1, field2) -> + Format.asprintf + "Mindestens eines der Felder '%s' oder '%s' muss ausgewählt werden." + (field_to_string field1) + (field_to_string field2) | AlreadyInvitedToExperiment names -> Format.asprintf "Die folgenden Kontakte wurden bereits zu diesem Experiment eingeladen: \ diff --git a/pool/app/pool_common/locales/locales_en.ml b/pool/app/pool_common/locales/locales_en.ml index dbf0a0a90..68e3648fa 100644 --- a/pool/app/pool_common/locales/locales_en.ml +++ b/pool/app/pool_common/locales/locales_en.ml @@ -253,6 +253,8 @@ let rec field_to_string = | Setting -> "setting" | Settings -> "settings" | ShowUpCount -> "show ups" + | ShowToAdmins -> "Show to admins" + | ShowToContacts -> "Show to contacts" | ShowExteralDataIdLinks -> "show links to external data identifiers" | SignedUpAt -> "signed up at" | SignUpCount -> "new sign ups" @@ -447,6 +449,11 @@ let rec error_to_string = |> CCString.trim |> Format.asprintf "%s has to be provided in at least one language." |> CCString.capitalize_ascii + | AtLeastOneSelected (field1, field2) -> + Format.asprintf + "At least one of the fields '%s' or '%s' has to be selected." + (field_to_string field1) + (field_to_string field2) | AlreadyInvitedToExperiment names -> Format.asprintf "The following contacts have already been invited to this experiment: %s" diff --git a/pool/app/pool_database/migrations/migration_202410031211.ml b/pool/app/pool_database/migrations/migration_202410031211.ml index 517de4058..0dc40fbd0 100644 --- a/pool/app/pool_database/migrations/migration_202410031211.ml +++ b/pool/app/pool_database/migrations/migration_202410031211.ml @@ -8,6 +8,8 @@ let create_pool_announcements_table = `text` text, start_at timestamp, end_at timestamp, + show_to_admins BOOLEAN NOT NULL DEFAULT FALSE, + show_to_contacts BOOLEAN NOT NULL DEFAULT FALSE, created_at timestamp NOT NULL DEFAULT CURRENT_TIMESTAMP, updated_at timestamp NOT NULL DEFAULT CURRENT_TIMESTAMP ON UPDATE CURRENT_TIMESTAMP, PRIMARY KEY (id), diff --git a/pool/cqrs_command/announcement_command.ml b/pool/cqrs_command/announcement_command.ml index c0fe20c24..77fccf820 100644 --- a/pool/cqrs_command/announcement_command.ml +++ b/pool/cqrs_command/announcement_command.ml @@ -6,21 +6,22 @@ let src = Logs.Src.create "announcement.cqrs" type command = { start_at : StartAt.t option ; end_at : EndAt.t option + ; show_to_admins : ShowToAdmins.t + ; show_to_contacts : ShowToContacts.t } -let command start_at end_at = { start_at; end_at } +let command start_at end_at show_to_admins show_to_contacts = + { start_at; end_at; show_to_admins; show_to_contacts } +;; -let schema - : ( Conformist.error_msg - , StartAt.t option -> EndAt.t option -> command - , command ) - Conformist.t - = +let schema = Pool_conformist.( make Field. [ Conformist.optional @@ StartAt.schema () ; Conformist.optional @@ EndAt.schema () + ; ShowToAdmins.(schema ~default:init ()) + ; ShowToContacts.(schema ~default:init ()) ] command) ;; @@ -33,6 +34,17 @@ let validate_start_end ~start_at ~end_at = | _ -> Ok () ;; +let validate_display_bools ~show_to_admins ~show_to_contacts = + match + ShowToAdmins.value show_to_admins, ShowToContacts.value show_to_contacts + with + | false, false -> + Error + Pool_message.( + Error.AtLeastOneSelected (Field.ShowToAdmins, Field.ShowToContacts)) + | _ -> Ok () +;; + module Create : sig include Common.CommandSig @@ -55,13 +67,16 @@ end = struct ?id text tenant_ids - ({ start_at; end_at } : t) + ({ start_at; end_at; show_to_admins; show_to_contacts } : t) = let open CCResult in Logs.info ~src (fun m -> m "Handle command Create" ~tags); let* () = validate_start_end ~start_at ~end_at in + let* () = validate_display_bools ~show_to_admins ~show_to_contacts in let* text = Text.create text in - let announcement = create ?id text start_at end_at in + let announcement = + create ?id text start_at end_at show_to_admins show_to_contacts + in Ok [ Created (announcement, tenant_ids) |> Pool_event.announcement ] ;; @@ -96,13 +111,22 @@ end = struct announcement text tenant_ids - ({ start_at; end_at } : t) + ({ start_at; end_at; show_to_admins; show_to_contacts } : t) = let open CCResult in Logs.info ~src (fun m -> m "Handle command Update" ~tags); let* () = validate_start_end ~start_at ~end_at in + let* () = validate_display_bools ~show_to_admins ~show_to_contacts in let* text = Text.create text in - let updated = { announcement with text; start_at; end_at } in + let updated = + { announcement with + text + ; start_at + ; end_at + ; show_to_admins + ; show_to_contacts + } + in Ok [ Updated (updated, tenant_ids) |> Pool_event.announcement ] ;; diff --git a/pool/pool_message/field.ml b/pool/pool_message/field.ml index d993287bb..97b9589bd 100644 --- a/pool/pool_message/field.ml +++ b/pool/pool_message/field.ml @@ -300,6 +300,8 @@ type t = | ShowExteralDataIdLinks [@name "show_external_data_id_links"] [@printer go "show_external_data_id_links"] | ShowUpCount [@name "show_up_count"] [@printer go "show_up_count"] + | ShowToAdmins [@name "show_to_admins"] [@printer go "show_to_admins"] + | ShowToContacts [@name "show_to_contacts"] [@printer go "show_to_contacts"] | SignedUpAt [@name "signed_up_at"] [@printer go "signed_up_at"] | SignUpCount [@name "sign_up_count"] [@printer go "sign_up_count"] | SMS [@name "sms"] [@printer go "sms"] diff --git a/pool/pool_message/field.mli b/pool/pool_message/field.mli index aa392a0a5..4168313a0 100644 --- a/pool/pool_message/field.mli +++ b/pool/pool_message/field.mli @@ -239,6 +239,8 @@ type t = | Settings | ShowExteralDataIdLinks | ShowUpCount + | ShowToAdmins + | ShowToContacts | SignedUpAt | SignUpCount | SMS diff --git a/pool/pool_message/pool_message_error.ml b/pool/pool_message/pool_message_error.ml index 5ae50b336..1251b01e3 100644 --- a/pool/pool_message/pool_message_error.ml +++ b/pool/pool_message/pool_message_error.ml @@ -17,6 +17,7 @@ type t = | AssignmentIsClosed | AssignmentsHaveErrors | AtLeastOneLanguageRequired of Field.t + | AtLeastOneSelected of Field.t * Field.t | Authorization of string | CannotBeDeleted of Field.t | CannotBeUpdated of Field.t diff --git a/pool/pool_model/base.ml b/pool/pool_model/base.ml index c2bac5bac..c9b8dd1bc 100644 --- a/pool/pool_model/base.ml +++ b/pool/pool_model/base.ml @@ -90,8 +90,11 @@ module Boolean = struct | _ -> false ;; - let schema field () : (Pool_message.Error.t, t) Pool_conformist.Field.t = + let schema ?default field () + : (Pool_message.Error.t, t) Pool_conformist.Field.t + = Pool_conformist.schema_decoder + ?default (fun m -> m |> bool_of_string_opt diff --git a/pool/web/view/page/page_root_announcement.ml b/pool/web/view/page/page_root_announcement.ml index 0b6fb62f4..20b90cfc0 100644 --- a/pool/web/view/page/page_root_announcement.ml +++ b/pool/web/view/page/page_root_announcement.ml @@ -17,14 +17,19 @@ let list { Pool_context.language; _ } (annoucements, query) = ~icon:Icon.Add ~control:(language, Control.Add None) in + let custom field = `custom (txt (field_to_string language field)) in let cols = - [ `custom (txt (field_to_string language Field.Text)) + [ custom Field.Text ; `column column_start ; `column column_end + ; custom Field.ShowToAdmins + ; custom Field.ShowToContacts ; `custom create_btn ] in - let row ({ id; start_at; end_at; text; _ } : t) = + let row + ({ id; start_at; end_at; text; show_to_admins; show_to_contacts; _ } : t) + = let open CCOption in let edit_btn = let open Component in @@ -32,9 +37,17 @@ let list { Pool_context.language; _ } (annoucements, query) = |> Input.link_as_button ~style:`Primary ~icon:Icon.Create in let format_time = Utils.Ptime.formatted_date_time in + let bool_icon = + let open Component.Icon in + function + | true -> to_html Checkmark + | false -> to_html Close + in [ Text.find language text |> Unsafe.data ; start_at |> map_or ~default:"" (StartAt.value %> format_time) |> txt ; end_at |> map_or ~default:"" (EndAt.value %> format_time) |> txt + ; show_to_admins |> ShowToAdmins.value |> bool_icon + ; show_to_contacts |> ShowToContacts.value |> bool_icon ; edit_btn ] |> CCList.map (CCList.return %> td) @@ -148,6 +161,26 @@ let form ; div ~a:[ a_class [ "input-group" ] ] checkboxes ] in + let show_to_html = + div + [ Input.checkbox_element + ?flash_fetcher + ?value: + (announcement + >|= fun { show_to_admins; _ } -> ShowToAdmins.value show_to_admins + ) + language + Field.ShowToAdmins + ; Input.checkbox_element + ?flash_fetcher + ?value: + (announcement + >|= fun { show_to_contacts; _ } -> + ShowToContacts.value show_to_contacts) + language + Field.ShowToContacts + ] + in div ~a:[ a_class [ "trim"; "safety-margin" ] ] [ h1 [ txt (Pool_common.Utils.control_to_string language title) ] @@ -175,6 +208,7 @@ let form ; div ~a:[ a_class [ "stack" ] ] text_inputs ] ; tenant_select + ; show_to_html ; div ~a:[ a_class [ "full-width"; "flexrow"; "justify-end" ] ] [ submit_element language title () ] From 4dcba49482a6f5e248345f5981705a1d1a435428 Mon Sep 17 00:00:00 2001 From: Timo Huber Date: Thu, 10 Oct 2024 11:23:49 +0200 Subject: [PATCH 4/9] display announcement on tenants --- pool/app/announcement/announcement.ml | 1 + pool/app/announcement/announcement.mli | 2 ++ pool/app/announcement/entity.ml | 2 ++ pool/app/announcement/repo/repo.ml | 28 +++++++++++++++++++ pool/app/pool_context/dune | 10 ++++++- pool/app/pool_context/entity.ml | 20 +++++++++++-- pool/app/pool_context/pool_context.mli | 2 ++ .../migrations/migration_202410031211.ml | 4 +-- pool/web/handler/public.ml | 9 +++++- pool/web/middleware/middleware_context.ml | 24 +++++++++++++++- pool/web/middleware/middleware_root.ml | 9 +++++- pool/web/view/component/component.ml | 1 + .../view/component/component_announcement.ml | 9 ++++++ .../view/component/component_announcement.mli | 4 +++ pool/web/view/layout/layout.ml | 18 ++++++++++-- pool/web/view/layout/layout_utils.ml | 7 +++-- pool/web/view/page/page_root_announcement.ml | 2 +- 17 files changed, 138 insertions(+), 14 deletions(-) create mode 100644 pool/web/view/component/component_announcement.ml create mode 100644 pool/web/view/component/component_announcement.mli diff --git a/pool/app/announcement/announcement.ml b/pool/app/announcement/announcement.ml index 14884eaf5..d3eba85c2 100644 --- a/pool/app/announcement/announcement.ml +++ b/pool/app/announcement/announcement.ml @@ -5,3 +5,4 @@ include Entity_guard let find = Repo.find let all = Repo.all let find_admin = Repo.find_admin +let find_by_user = Repo.find_by_user diff --git a/pool/app/announcement/announcement.mli b/pool/app/announcement/announcement.mli index f6eb07108..287c07f7a 100644 --- a/pool/app/announcement/announcement.mli +++ b/pool/app/announcement/announcement.mli @@ -67,6 +67,7 @@ val pp : Format.formatter -> t -> unit val show : t -> string val t_of_yojson : Yojson.Safe.t -> t val yojson_of_t : t -> Yojson.Safe.t +val sexp_of_t : t -> Sexplib.Sexp.t val create : ?id:Id.t @@ -91,6 +92,7 @@ val find_admin -> Id.t -> (admin, Pool_message.Error.t) Lwt_result.t +val find_by_user : Database.Label.t -> [< `Admin | `Contact ] -> t option Lwt.t val column_start : Query.Column.t val column_end : Query.Column.t val filterable_by : Query.Filter.human option diff --git a/pool/app/announcement/entity.ml b/pool/app/announcement/entity.ml index 33cc5417c..e2594be27 100644 --- a/pool/app/announcement/entity.ml +++ b/pool/app/announcement/entity.ml @@ -73,6 +73,8 @@ type t = } [@@deriving eq, show, yojson] +let sexp_of_t { id; _ } = Id.sexp_of_t id + let create ?(id = Id.create ()) tet diff --git a/pool/app/announcement/repo/repo.ml b/pool/app/announcement/repo/repo.ml index ec6fdfe2d..fd6b1d1dc 100644 --- a/pool/app/announcement/repo/repo.ml +++ b/pool/app/announcement/repo/repo.ml @@ -182,3 +182,31 @@ let find_admin pool id = let* tenants = TenantMapping.find_tenants_by_announcement pool id in Lwt_result.return (announcement, tenants) ;; + +let find_by_user_request context = + let open Caqti_request.Infix in + let where = + match context with + | `Admin -> "pool_announcements.show_to_admins = 1" + | `Contact -> "pool_announcements.show_to_contacts = 1" + in + Format.asprintf + {sql| + INNER JOIN pool_announcement_tenants ON pool_announcements.uuid = pool_announcement_tenants.pool_announcement_uuid + INNER JOIN pool_tenant ON pool_announcement_tenants.pool_tenant_uuid = pool_tenant.uuid + WHERE + pool_tenant.database_label = $1 + AND %s + AND(pool_announcements.start_at < NOW() + OR pool_announcements.start_at IS NULL) + AND(pool_announcements.end_at > NOW() + OR pool_announcements.end_at IS NULL) + |sql} + where + |> find_request_sql + |> Database.Repo.Label.t ->! Repo_entity.t +;; + +let find_by_user database_label context = + Database.find_opt Database.root (find_by_user_request context) database_label +;; diff --git a/pool/app/pool_context/dune b/pool/app/pool_context/dune index 9f21efa3b..87a7293a7 100644 --- a/pool/app/pool_context/dune +++ b/pool/app/pool_context/dune @@ -1,6 +1,14 @@ (library (name pool_context) - (libraries admin contact logger pool_common pool_tenant sihl utils) + (libraries + admin + announcement + contact + logger + pool_common + pool_tenant + sihl + utils) (preprocess (pps lwt_ppx diff --git a/pool/app/pool_context/entity.ml b/pool/app/pool_context/entity.ml index 064656664..cc7755ab5 100644 --- a/pool/app/pool_context/entity.ml +++ b/pool/app/pool_context/entity.ml @@ -29,13 +29,29 @@ type t = ; csrf : string ; user : user ; guardian : Guard.PermissionOnTarget.t list [@sexp.list] + ; announcement : Announcement.t option } [@@deriving show, sexp_of] let create - (query_language, language, database_label, message, csrf, user, guardian) + ( query_language + , language + , database_label + , message + , csrf + , user + , guardian + , announcement ) = - { query_language; language; database_label; message; csrf; user; guardian } + { query_language + ; language + ; database_label + ; message + ; csrf + ; user + ; guardian + ; announcement + } ;; let find_context key req = diff --git a/pool/app/pool_context/pool_context.mli b/pool/app/pool_context/pool_context.mli index 8e82ee743..28aee643c 100644 --- a/pool/app/pool_context/pool_context.mli +++ b/pool/app/pool_context/pool_context.mli @@ -27,6 +27,7 @@ type t = ; csrf : string ; user : user ; guardian : Guard.PermissionOnTarget.t list + ; announcement : Announcement.t option } val show : t -> string @@ -46,6 +47,7 @@ val create * string * user * Guard.PermissionOnTarget.t list + * Announcement.t option -> t module Tenant : sig diff --git a/pool/app/pool_database/migrations/migration_202410031211.ml b/pool/app/pool_database/migrations/migration_202410031211.ml index 0dc40fbd0..222d1b37e 100644 --- a/pool/app/pool_database/migrations/migration_202410031211.ml +++ b/pool/app/pool_database/migrations/migration_202410031211.ml @@ -6,8 +6,8 @@ let create_pool_announcements_table = id BIGINT UNSIGNED AUTO_INCREMENT, uuid BINARY(16) NOT NULL, `text` text, - start_at timestamp, - end_at timestamp, + start_at timestamp NULL, + end_at timestamp NULL, show_to_admins BOOLEAN NOT NULL DEFAULT FALSE, show_to_contacts BOOLEAN NOT NULL DEFAULT FALSE, created_at timestamp NOT NULL DEFAULT CURRENT_TIMESTAMP, diff --git a/pool/web/handler/public.ml b/pool/web/handler/public.ml index 20aed32bc..7553a9a50 100644 --- a/pool/web/handler/public.ml +++ b/pool/web/handler/public.ml @@ -130,7 +130,14 @@ let denied req = let open Pool_context in let csrf = Sihl.Web.Csrf.find_exn req in create - (None, Pool_common.Language.En, database_label, None, csrf, Guest, []) + ( None + , Pool_common.Language.En + , database_label + , None + , csrf + , Guest + , [] + , None ) in Layout.Root.create context html) ||> Sihl.Web.Response.of_html diff --git a/pool/web/middleware/middleware_context.ml b/pool/web/middleware/middleware_context.ml index e72daecae..a2dae23f3 100644 --- a/pool/web/middleware/middleware_context.ml +++ b/pool/web/middleware/middleware_context.ml @@ -80,8 +80,30 @@ let context () = in Lwt.return (query_lang, language, []) in + let%lwt announcement = + match is_root with + | true -> Lwt.return_none + | false -> + let context = + match user with + | Admin _ -> Some `Admin + | Contact _ -> Some `Contact + | Guest -> None + in + context + |> CCOption.map_or + ~default:Lwt.return_none + (Announcement.find_by_user database_label) + in create - (query_lang, language, database_label, message, csrf, user, guardian) + ( query_lang + , language + , database_label + , message + , csrf + , user + , guardian + , announcement ) |> Lwt.return_ok in match context with diff --git a/pool/web/middleware/middleware_root.ml b/pool/web/middleware/middleware_root.ml index 4fa16f0ad..b19ff0959 100644 --- a/pool/web/middleware/middleware_root.ml +++ b/pool/web/middleware/middleware_root.ml @@ -9,7 +9,14 @@ let from_root_only () = let open Pool_context in let csrf = Sihl.Web.Csrf.find_exn req in create - (None, Pool_common.Language.En, Database.root, None, csrf, Guest, []) + ( None + , Pool_common.Language.En + , Database.root + , None + , csrf + , Guest + , [] + , None ) in Page.Utils.error_page_not_found Pool_common.Language.En () |> Layout.Root.create context diff --git a/pool/web/view/component/component.ml b/pool/web/view/component/component.ml index 6f9d627a8..4b01a224c 100644 --- a/pool/web/view/component/component.ml +++ b/pool/web/view/component/component.ml @@ -1,3 +1,4 @@ +module Announcement = Component_announcement module Button = Button module ButtonGroup = Component_button_group module Calendar = Component_calendar diff --git a/pool/web/view/component/component_announcement.ml b/pool/web/view/component/component_announcement.ml new file mode 100644 index 000000000..d2e2d2d4b --- /dev/null +++ b/pool/web/view/component/component_announcement.ml @@ -0,0 +1,9 @@ +open Tyxml.Html +open Announcement + +let make language announcement = + let text = Text.find language announcement.text in + div + ~a:[ a_class [ "trim"; "safety-margin"; "gap" ] ] + [ div ~a:[ a_class [ "notification"; "error" ] ] [ Unsafe.data text ] ] +;; diff --git a/pool/web/view/component/component_announcement.mli b/pool/web/view/component/component_announcement.mli new file mode 100644 index 000000000..7544a14ce --- /dev/null +++ b/pool/web/view/component/component_announcement.mli @@ -0,0 +1,4 @@ +val make + : Pool_common.Language.t + -> Announcement.t + -> [> Html_types.div ] Tyxml_html.elt diff --git a/pool/web/view/layout/layout.ml b/pool/web/view/layout/layout.ml index 9cf478063..c0f12f265 100644 --- a/pool/web/view/layout/layout.ml +++ b/pool/web/view/layout/layout.ml @@ -15,8 +15,14 @@ let language_attribute lang = module Tenant = struct let create ?active_navigation - ({ Pool_context.database_label; language; query_language; message; user; _ } - as context) + ({ Pool_context.database_label + ; language + ; query_language + ; message + ; user + ; announcement + ; _ + } as context) Pool_context.Tenant.{ tenant_languages; tenant } children = @@ -39,7 +45,13 @@ module Tenant = struct let htmx_notification = div ~a:[ a_id Http_utils.Htmx.notification_id ] [] in - let content = main_tag [ message; htmx_notification; children ] in + let announcement = + CCOption.map (Component.Announcement.make language) announcement + in + let children = div ~a:[ a_class [ "stack" ] ] [ children ] in + let content = + main_tag ?announcement [ message; htmx_notification; children ] + in let head_tags = let favicon = tenant.icon diff --git a/pool/web/view/layout/layout_utils.ml b/pool/web/view/layout/layout_utils.ml index 515fdd5da..09edafb97 100644 --- a/pool/web/view/layout/layout_utils.ml +++ b/pool/web/view/layout/layout_utils.ml @@ -11,8 +11,11 @@ let assets = function let charset = meta ~a:[ a_charset "utf8" ] () let body_tag_classnames = [ "height-100"; "flexcolumn" ] -let main_tag children = - main [ div ~a:[ a_class [ "inset-xl"; "sm-inset-lg"; "vertical" ] ] children ] +let main_tag ?(announcement = txt "") children = + main + [ announcement + ; div ~a:[ a_class [ "inset-xl"; "sm-inset-lg"; "vertical" ] ] children + ] ;; let viewport = diff --git a/pool/web/view/page/page_root_announcement.ml b/pool/web/view/page/page_root_announcement.ml index 20b90cfc0..2efb0f8ef 100644 --- a/pool/web/view/page/page_root_announcement.ml +++ b/pool/web/view/page/page_root_announcement.ml @@ -1,6 +1,7 @@ open Tyxml.Html open CCFun.Infix open Pool_message +module Input = Component.Input let announcement_path = Http_utils.Url.Root.announcement_path let field_to_string = Pool_common.Utils.field_to_string_capitalized @@ -79,7 +80,6 @@ let form available_tenants system_languages = - let open Component in let open Announcement in let open CCOption.Infix in let announcement, tenants = From 38c1a25b8ad1f3991a53da2bf9c1cf975e5bc673 Mon Sep 17 00:00:00 2001 From: Timo Huber Date: Thu, 10 Oct 2024 15:51:49 +0200 Subject: [PATCH 5/9] allow banners to be hidden --- pool/app/announcement/announcement.mli | 7 +++- pool/app/announcement/event.ml | 2 + pool/app/announcement/repo/repo.ml | 38 ++++++++++++++++--- pool/app/pool_common/locales/locales_de.ml | 1 + pool/app/pool_common/locales/locales_en.ml | 1 + pool/app/pool_context/pool_context.ml | 6 +++ pool/app/pool_context/pool_context.mli | 1 + .../migrations/migration_202410031211.ml | 24 ++++++++++-- pool/cqrs_command/announcement_command.ml | 23 +++++++++++ pool/pool_message/pool_message_control.ml | 1 + pool/pool_message/pool_message_control.mli | 1 + pool/routes/routes.ml | 9 ++++- pool/web/handler/public.ml | 20 ++++++++++ pool/web/middleware/middleware_context.ml | 5 ++- pool/web/utils/http_utils_url.ml | 11 ++++-- .../view/component/component_announcement.ml | 34 +++++++++++++++-- .../view/component/component_announcement.mli | 1 + pool/web/view/layout/layout.ml | 3 +- resources/index.scss | 20 ++++++++++ 19 files changed, 187 insertions(+), 21 deletions(-) diff --git a/pool/app/announcement/announcement.mli b/pool/app/announcement/announcement.mli index 287c07f7a..0e610d53a 100644 --- a/pool/app/announcement/announcement.mli +++ b/pool/app/announcement/announcement.mli @@ -92,7 +92,11 @@ val find_admin -> Id.t -> (admin, Pool_message.Error.t) Lwt_result.t -val find_by_user : Database.Label.t -> [< `Admin | `Contact ] -> t option Lwt.t +val find_by_user + : Database.Label.t + -> [< `Admin | `Contact ] * Pool_common.Id.t + -> t option Lwt.t + val column_start : Query.Column.t val column_end : Query.Column.t val filterable_by : Query.Filter.human option @@ -104,6 +108,7 @@ val default_query : Query.t type event = | Created of (t * Pool_tenant.Id.t list) | Updated of (t * Pool_tenant.Id.t list) + | Hidden of (t * Pool_common.Id.t) val handle_event : Database.Label.t -> event -> unit Lwt.t val equal_event : event -> event -> bool diff --git a/pool/app/announcement/event.ml b/pool/app/announcement/event.ml index 18b6e0ad9..f38abf2b2 100644 --- a/pool/app/announcement/event.ml +++ b/pool/app/announcement/event.ml @@ -3,6 +3,7 @@ open Entity type event = | Created of (t * Pool_tenant.Id.t list) | Updated of (t * Pool_tenant.Id.t list) + | Hidden of (t * Pool_common.Id.t) [@@deriving eq, show] let handle_event pool = @@ -17,4 +18,5 @@ let handle_event pool = in Lwt.return_unit | Updated m -> Repo.update pool m + | Hidden (m, user_id) -> Repo.hide user_id m ;; diff --git a/pool/app/announcement/repo/repo.ml b/pool/app/announcement/repo/repo.ml index fd6b1d1dc..2ed308b70 100644 --- a/pool/app/announcement/repo/repo.ml +++ b/pool/app/announcement/repo/repo.ml @@ -1,5 +1,8 @@ module Dynparam = Database.Dynparam +let caqti_id = Pool_common.Repo.Id.t +let caqti_tenant_id = Pool_tenant.Repo.Id.t + let sql_select_columns = [ Entity.Id.sql_select_fragment ~field:"pool_announcements.uuid" ; "pool_announcements.text" @@ -15,9 +18,6 @@ let sql_select_columns = module TenantMapping = struct open Caqti_request.Infix - let caqti_id = Pool_common.Repo.Id.t - let caqti_tenant_id = Pool_tenant.Repo.Id.t - let delete_existing_request tenant_ids = CCList.mapi (fun i _ -> Format.asprintf "UNHEX(REPLACE($%n, '-', ''))" (i + 2)) @@ -194,6 +194,8 @@ let find_by_user_request context = {sql| INNER JOIN pool_announcement_tenants ON pool_announcements.uuid = pool_announcement_tenants.pool_announcement_uuid INNER JOIN pool_tenant ON pool_announcement_tenants.pool_tenant_uuid = pool_tenant.uuid + LEFT JOIN pool_announcement_users_hide ON pool_announcements.uuid = pool_announcement_users_hide.pool_announcement_uuid + AND pool_announcement_users_hide.user_users_uuid = UNHEX(REPLACE($2, '-', '')) WHERE pool_tenant.database_label = $1 AND %s @@ -201,12 +203,36 @@ let find_by_user_request context = OR pool_announcements.start_at IS NULL) AND(pool_announcements.end_at > NOW() OR pool_announcements.end_at IS NULL) + AND pool_announcement_users_hide.user_users_uuid IS NULL |sql} where |> find_request_sql - |> Database.Repo.Label.t ->! Repo_entity.t + |> Caqti_type.(t2 Database.Repo.Label.t Pool_common.Repo.Id.t) + ->! Repo_entity.t +;; + +let find_by_user database_label (context, user_id) = + Database.find_opt + Database.root + (find_by_user_request context) + (database_label, user_id) +;; + +let hide_requeset = + let open Caqti_request.Infix in + {sql| + INSERT INTO pool_announcement_users_hide ( + pool_announcement_uuid, + user_users_uuid + ) VALUES ( + UNHEX(REPLACE($1, '-', '')), + UNHEX(REPLACE($2, '-', '')) + ) ON DUPLICATE KEY UPDATE + updated_at = NOW() + |sql} + |> Caqti_type.(t2 caqti_id caqti_id ->. Caqti_type.unit) ;; -let find_by_user database_label context = - Database.find_opt Database.root (find_by_user_request context) database_label +let hide user_id annoucement = + Database.exec Database.root hide_requeset (annoucement.Entity.id, user_id) ;; diff --git a/pool/app/pool_common/locales/locales_de.ml b/pool/app/pool_common/locales/locales_de.ml index 15fb7f6c8..69a31e06a 100644 --- a/pool/app/pool_common/locales/locales_de.ml +++ b/pool/app/pool_common/locales/locales_de.ml @@ -757,6 +757,7 @@ let control_to_string = | Enroll -> format_submit "einschreiben" None | EnterNewCellPhone -> "eine andere Nummer eingeben" | Filter field -> format_submit "filtern" field + | Hide field -> format_submit "verbergen" field | Login -> format_submit "login" None | LoadDefaultTemplate -> format_submit "Standardtemplate laden" None | Manage field -> format_submit "manage" (Some field) diff --git a/pool/app/pool_common/locales/locales_en.ml b/pool/app/pool_common/locales/locales_en.ml index 68e3648fa..bc3493e7d 100644 --- a/pool/app/pool_common/locales/locales_en.ml +++ b/pool/app/pool_common/locales/locales_en.ml @@ -713,6 +713,7 @@ let control_to_string = | Enroll -> format_submit "enroll" None | EnterNewCellPhone -> "Enter a different number" | Filter field -> format_submit "filter" field + | Hide field -> format_submit "hide" field | Login -> format_submit "login" None | LoadDefaultTemplate -> format_submit "load default template" None | Manage field -> format_submit "manage" (Some field) diff --git a/pool/app/pool_context/pool_context.ml b/pool/app/pool_context/pool_context.ml index f4c2c1cde..fb2bbaa98 100644 --- a/pool/app/pool_context/pool_context.ml +++ b/pool/app/pool_context/pool_context.ml @@ -12,6 +12,12 @@ let get_admin_user = function | Admin admin -> Ok admin ;; +let get_user_id = function + | Guest -> None + | Contact contact -> Some (Contact.id contact |> Contact.Id.to_common) + | Admin admin -> Some (Admin.id admin |> Admin.Id.to_common) +;; + module Utils = struct let find_authorizable_opt ?(admin_only = false) database_label user = let open Utils.Lwt_result.Infix in diff --git a/pool/app/pool_context/pool_context.mli b/pool/app/pool_context/pool_context.mli index 28aee643c..b87e25ba6 100644 --- a/pool/app/pool_context/pool_context.mli +++ b/pool/app/pool_context/pool_context.mli @@ -72,6 +72,7 @@ val sexp_of_t : t -> Sexplib.Sexp.t val is_from_root : t -> bool val user_is_admin : user -> bool val get_admin_user : user -> (Admin.t, Pool_message.Error.t) result +val get_user_id : user -> Pool_common.Id.t option module Utils : sig val find_authorizable_opt diff --git a/pool/app/pool_database/migrations/migration_202410031211.ml b/pool/app/pool_database/migrations/migration_202410031211.ml index 222d1b37e..21b89b7aa 100644 --- a/pool/app/pool_database/migrations/migration_202410031211.ml +++ b/pool/app/pool_database/migrations/migration_202410031211.ml @@ -29,16 +29,34 @@ let create_pool_announcement_tenants_table = 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_announchment_tenant UNIQUE KEY (pool_announcement_uuid, pool_tenant_uuid), - CONSTRAINT fk_pool_announcement_uuid FOREIGN KEY (pool_announcement_uuid) REFERENCES pool_announcements(uuid) ON DELETE CASCADE, + CONSTRAINT unique_announcement_tenant UNIQUE KEY (pool_announcement_uuid, pool_tenant_uuid), + CONSTRAINT fk_pool_announcement_tenant_announcement_uuid FOREIGN KEY (pool_announcement_uuid) REFERENCES pool_announcements(uuid) ON DELETE CASCADE, CONSTRAINT fk_pool_tenant_uuid FOREIGN KEY (pool_tenant_uuid) REFERENCES pool_tenant(uuid) ON DELETE CASCADE ) ENGINE=InnoDB DEFAULT CHARSET=utf8mb4 COLLATE=utf8mb4_unicode_ci |sql} ;; +let create_pool_announcement_users_hide_table = + Database.Migration.Step.create + ~label:"create pool_announcement_users_hide table" + {sql| + CREATE TABLE IF NOT EXISTS pool_announcement_users_hide ( + id BIGINT UNSIGNED AUTO_INCREMENT, + pool_announcement_uuid BINARY(16) NOT NULL, + user_users_uuid BINARY(16) NOT 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 fk_pool_announcement_user_announcement_uuid FOREIGN KEY (pool_announcement_uuid) REFERENCES pool_announcements(uuid) ON DELETE CASCADE, + CONSTRAINT unique_announcement_contact UNIQUE KEY (pool_announcement_uuid, user_users_uuid) + ) ENGINE=InnoDB DEFAULT CHARSET=utf8mb4 COLLATE=utf8mb4_unicode_ci + |sql} +;; + let migration () = Database.Migration.( empty "202410031211" |> add_step create_pool_announcements_table - |> add_step create_pool_announcement_tenants_table) + |> add_step create_pool_announcement_tenants_table + |> add_step create_pool_announcement_users_hide_table) ;; diff --git a/pool/cqrs_command/announcement_command.ml b/pool/cqrs_command/announcement_command.ml index 77fccf820..49ebd3225 100644 --- a/pool/cqrs_command/announcement_command.ml +++ b/pool/cqrs_command/announcement_command.ml @@ -137,3 +137,26 @@ end = struct let effects = Access.update end + +type hide = Pool_context.user * Announcement.t + +module Hide : sig + type t = hide + + val handle + : ?tags:Logs.Tag.set + -> t + -> (Pool_event.t list, Pool_message.Error.t) result +end = struct + type t = hide + + let handle ?(tags = Logs.Tag.empty) (user, announcement) = + let open CCResult in + Logs.info ~src (fun m -> m "Handle command Hide" ~tags); + let* user_id = + Pool_context.get_user_id user + |> CCOption.to_result Pool_message.(Error.NotFound Field.User) + in + Ok [ Hidden (announcement, user_id) |> Pool_event.announcement ] + ;; +end diff --git a/pool/pool_message/pool_message_control.ml b/pool/pool_message/pool_message_control.ml index 5671c82a2..d0b6c83e3 100644 --- a/pool/pool_message/pool_message_control.ml +++ b/pool/pool_message/pool_message_control.ml @@ -25,6 +25,7 @@ type t = | Enroll | EnterNewCellPhone | Filter of Field.t option + | Hide of Field.t option | LoadDefaultTemplate | Login | Manage of Field.t diff --git a/pool/pool_message/pool_message_control.mli b/pool/pool_message/pool_message_control.mli index 24cd2fbef..9b885caa2 100644 --- a/pool/pool_message/pool_message_control.mli +++ b/pool/pool_message/pool_message_control.mli @@ -22,6 +22,7 @@ type t = | Enroll | EnterNewCellPhone | Filter of Field.t option + | Hide of Field.t option | LoadDefaultTemplate | Login | Manage of Field.t diff --git a/pool/routes/routes.ml b/pool/routes/routes.ml index 298f15f3b..34e53adb0 100644 --- a/pool/routes/routes.ml +++ b/pool/routes/routes.ml @@ -68,6 +68,13 @@ module Public = struct in choose ~scope:(Queue |> url_key) specific in + let announcements = + let open Handler.Public in + let specific = [ post "hide" hide_announcement ] in + choose + ~scope:Field.(human_url Announcement) + [ choose ~scope:Field.(url_key Announcement) specific ] + in Handler.Public.( choose ~middlewares: @@ -116,7 +123,7 @@ module Public = struct [ CustomMiddleware.Guardian.require_user_type_of Pool_context.UserType.[ Contact; Admin ] ] - [ get "/logout" Login.logout ] + [ get "/logout" Login.logout; announcements ] ; get "/denied" Handler.Public.denied ]) ;; diff --git a/pool/web/handler/public.ml b/pool/web/handler/public.ml index 7553a9a50..e7b11ecee 100644 --- a/pool/web/handler/public.ml +++ b/pool/web/handler/public.ml @@ -241,3 +241,23 @@ let terms_and_conditions req = in result |> Http_utils.extract_happy_path ~src req ;; + +let hide_announcement req = + let open Http_utils in + let result { Pool_context.user; _ } = + let open Utils.Lwt_result.Infix in + let open Announcement in + let* announcement = + find_id Id.validate Field.Announcement req + |> Lwt_result.lift + >>= find Database.root + in + let* () = + Cqrs_command.Announcement_command.Hide.handle (user, announcement) + |> Lwt_result.lift + |>> Pool_event.handle_events Database.root + in + Tyxml.Html.txt "" |> Htmx.html_to_plain_text_response |> Lwt_result.return + in + result |> Htmx.handle_error_message ~src req +;; diff --git a/pool/web/middleware/middleware_context.ml b/pool/web/middleware/middleware_context.ml index a2dae23f3..2e46b9736 100644 --- a/pool/web/middleware/middleware_context.ml +++ b/pool/web/middleware/middleware_context.ml @@ -86,8 +86,9 @@ let context () = | false -> let context = match user with - | Admin _ -> Some `Admin - | Contact _ -> Some `Contact + | Admin admin -> Some (`Admin, Admin.(admin |> id |> Id.to_common)) + | Contact contact -> + Some (`Contact, Contact.(contact |> id |> Id.to_common)) | Guest -> None in context diff --git a/pool/web/utils/http_utils_url.ml b/pool/web/utils/http_utils_url.ml index 584fc6470..b9b164ca8 100644 --- a/pool/web/utils/http_utils_url.ml +++ b/pool/web/utils/http_utils_url.ml @@ -6,6 +6,12 @@ let append_opt suffix path = suffix |> CCOption.map_or ~default:path (Format.asprintf "%s/%s" path) ;; +let announcement_path ?suffix ?id () = + ("/" ^ Field.(show Announcement)) + |> append_opt (map Announcement.Id.value id) + |> append_opt suffix +;; + module Admin = struct let role_permission_path ?suffix ?role () = "/admin/settings/role-permission" @@ -58,9 +64,6 @@ module Root = struct let with_root = Format.asprintf "/root%s" let announcement_path ?suffix ?id () = - ("/" ^ Field.(show Announcement)) - |> append_opt (map Announcement.Id.value id) - |> append_opt suffix - |> with_root + announcement_path ?suffix ?id () |> with_root ;; end diff --git a/pool/web/view/component/component_announcement.ml b/pool/web/view/component/component_announcement.ml index d2e2d2d4b..6972da121 100644 --- a/pool/web/view/component/component_announcement.ml +++ b/pool/web/view/component/component_announcement.ml @@ -1,9 +1,37 @@ open Tyxml.Html +open Pool_message open Announcement -let make language announcement = +let make language csrf announcement = + let id = "annoncement-id-banner" in let text = Text.find language announcement.text in + let hide_button = + let url = + Http_utils.Url.announcement_path ~id:announcement.id ~suffix:"hide" () + |> Sihl.Web.externalize_path + in + let control = Control.Hide (Some Field.Announcement) in + form + ~a:[ a_class [ "close" ] ] + [ Component_input.csrf_element csrf () + ; span + ~a: + [ a_user_data "hx-post" url + ; a_user_data "hx-target" ("#" ^ id) + ; a_user_data "hx-params" "_csrf" + ; a_user_data "hx-trigger" "click" + ; a_user_data "hx-swap" "outerHTML" + ; a_class [ "pointer"; "has-icon" ] + ] + [ Component_icon.(to_html CloseCircle) + ; txt (Pool_common.Utils.control_to_string language control) + ] + ] + in div - ~a:[ a_class [ "trim"; "safety-margin"; "gap" ] ] - [ div ~a:[ a_class [ "notification"; "error" ] ] [ Unsafe.data text ] ] + ~a:[ a_class [ "trim"; "safety-margin"; "gap" ]; a_id id ] + [ div + ~a:[ a_class [ "notification"; "error"; "announcement" ] ] + [ hide_button; div [ Unsafe.data text ] ] + ] ;; diff --git a/pool/web/view/component/component_announcement.mli b/pool/web/view/component/component_announcement.mli index 7544a14ce..760306619 100644 --- a/pool/web/view/component/component_announcement.mli +++ b/pool/web/view/component/component_announcement.mli @@ -1,4 +1,5 @@ val make : Pool_common.Language.t + -> string -> Announcement.t -> [> Html_types.div ] Tyxml_html.elt diff --git a/pool/web/view/layout/layout.ml b/pool/web/view/layout/layout.ml index c0f12f265..248c15854 100644 --- a/pool/web/view/layout/layout.ml +++ b/pool/web/view/layout/layout.ml @@ -20,6 +20,7 @@ module Tenant = struct ; query_language ; message ; user + ; csrf ; announcement ; _ } as context) @@ -46,7 +47,7 @@ module Tenant = struct div ~a:[ a_id Http_utils.Htmx.notification_id ] [] in let announcement = - CCOption.map (Component.Announcement.make language) announcement + CCOption.map (Component.Announcement.make language csrf) announcement in let children = div ~a:[ a_class [ "stack" ] ] [ children ] in let content = diff --git a/resources/index.scss b/resources/index.scss index 3f27ea699..1363cb071 100644 --- a/resources/index.scss +++ b/resources/index.scss @@ -583,3 +583,23 @@ $n: 12; .break-grid { grid-column: 1; } + + +// ANNOUNCEMENT +.announcement { + .close { + float: right; + margin-left: $space-sm; + } + + @include mobile { + display: flex; + flex-direction: column-reverse; + + .close { + margin-left: 0; + margin-top: $space-sm; + float: none; + } + } +} \ No newline at end of file From 485f2dafe4193d3897e2a9a535b886d8d36b30db Mon Sep 17 00:00:00 2001 From: Timo Huber Date: Fri, 11 Oct 2024 07:48:40 +0200 Subject: [PATCH 6/9] add test case --- pool/app/announcement/entity.ml | 13 ++- pool/cqrs_command/announcement_command.ml | 41 +++++--- pool/test/announcement_test.ml | 116 ++++++++++++++++++++++ pool/test/command.ml | 3 +- pool/test/test_utils.ml | 38 +++++++ pool/web/handler/root_announcements.ml | 9 +- 6 files changed, 199 insertions(+), 21 deletions(-) create mode 100644 pool/test/announcement_test.ml diff --git a/pool/app/announcement/entity.ml b/pool/app/announcement/entity.ml index e2594be27..841b3922f 100644 --- a/pool/app/announcement/entity.ml +++ b/pool/app/announcement/entity.ml @@ -8,6 +8,8 @@ let ptime_schema field = field ;; +let equal_ptime a b = Sihl.Configuration.is_test () || Ptime.equal a b + module Id = struct include Pool_common.Id end @@ -29,6 +31,11 @@ module Text = struct | [] -> Error Pool_message.(Error.AtLeastOneLanguageRequired Field.Text) | names -> Ok names ;; + + let equal a b = + let sort = CCList.sort (fun (a, _) (b, _) -> Language.compare a b) in + if Sihl.Configuration.is_test () then equal (sort a) (sort b) else equal a b + ;; end module StartAt = struct @@ -36,6 +43,7 @@ module StartAt = struct let create m = m let schema () = ptime_schema Pool_message.Field.Start + let equal = equal_ptime end module EndAt = struct @@ -43,6 +51,7 @@ module EndAt = struct let create m = m let schema () = ptime_schema Pool_message.Field.End + let equal = equal_ptime end module ShowToAdmins = struct @@ -77,14 +86,14 @@ let sexp_of_t { id; _ } = Id.sexp_of_t id let create ?(id = Id.create ()) - tet + text start_at end_at show_to_admins show_to_contacts = { id - ; text = tet + ; text ; start_at ; end_at ; show_to_admins diff --git a/pool/cqrs_command/announcement_command.ml b/pool/cqrs_command/announcement_command.ml index 49ebd3225..f2e68d28d 100644 --- a/pool/cqrs_command/announcement_command.ml +++ b/pool/cqrs_command/announcement_command.ml @@ -4,17 +4,18 @@ open Announcement let src = Logs.Src.create "announcement.cqrs" type command = - { start_at : StartAt.t option + { text : (Pool_common.Language.t * string) list + ; start_at : StartAt.t option ; end_at : EndAt.t option ; show_to_admins : ShowToAdmins.t ; show_to_contacts : ShowToContacts.t } -let command start_at end_at show_to_admins show_to_contacts = - { start_at; end_at; show_to_admins; show_to_contacts } +let command text start_at end_at show_to_admins show_to_contacts = + { text; start_at; end_at; show_to_admins; show_to_contacts } ;; -let schema = +let schema texts = Pool_conformist.( make Field. @@ -23,7 +24,21 @@ let schema = ; ShowToAdmins.(schema ~default:init ()) ; ShowToContacts.(schema ~default:init ()) ] - command) + (command texts)) +;; + +let text_from_urlencoded urlencoded = + let open CCOption.Infix in + let open Pool_common.Language in + let sys_languages = all in + sys_languages + |> CCList.filter_map (fun lang -> + let field language = + Format.asprintf "%s[%s]" Pool_message.Field.(show Text) (show language) + in + CCList.assoc_opt ~eq:CCString.equal (field lang) urlencoded + >>= CCList.head_opt + >|= fun text -> lang, text) ;; let validate_start_end ~start_at ~end_at = @@ -53,7 +68,6 @@ module Create : sig val handle : ?tags:Logs.Tag.set -> ?id:Announcement.Id.t - -> (Pool_common.Language.t * string) list -> Pool_tenant.Id.t list -> t -> (Pool_event.t list, Pool_message.Error.t) result @@ -65,9 +79,8 @@ end = struct let handle ?(tags = Logs.Tag.empty) ?id - text tenant_ids - ({ start_at; end_at; show_to_admins; show_to_contacts } : t) + ({ text; start_at; end_at; show_to_admins; show_to_contacts } : t) = let open CCResult in Logs.info ~src (fun m -> m "Handle command Create" ~tags); @@ -81,7 +94,8 @@ end = struct ;; let decode data = - Pool_conformist.decode_and_validate schema data + let texts = text_from_urlencoded data in + Pool_conformist.decode_and_validate (schema texts) data |> CCResult.map_err Pool_message.to_conformist_error ;; @@ -96,7 +110,6 @@ module Update : sig val handle : ?tags:Logs.Tag.set -> Announcement.t - -> (Pool_common.Language.t * string) list -> Pool_tenant.Id.t list -> t -> (Pool_event.t list, Pool_message.Error.t) result @@ -108,10 +121,9 @@ end = struct let handle ?(tags = Logs.Tag.empty) - announcement - text + (announcement : Announcement.t) tenant_ids - ({ start_at; end_at; show_to_admins; show_to_contacts } : t) + ({ text; start_at; end_at; show_to_admins; show_to_contacts } : t) = let open CCResult in Logs.info ~src (fun m -> m "Handle command Update" ~tags); @@ -131,7 +143,8 @@ end = struct ;; let decode data = - Pool_conformist.decode_and_validate schema data + let text = text_from_urlencoded data in + Pool_conformist.decode_and_validate (schema text) data |> CCResult.map_err Pool_message.to_conformist_error ;; diff --git a/pool/test/announcement_test.ml b/pool/test/announcement_test.ml new file mode 100644 index 000000000..6b325b45c --- /dev/null +++ b/pool/test/announcement_test.ml @@ -0,0 +1,116 @@ +open Announcement +module Command = Cqrs_command.Announcement_command +open Pool_message +module Language = Pool_common.Language + +let get_exn = Test_utils.get_or_failwith + +module Data = struct + let boolean_fields = Field.[ show ShowToAdmins; show ShowToContacts ] + + let text_name lang = + Format.asprintf "%s[%s]" Field.(show Text) (Language.show lang) + ;; + + let text_en = "EN" + let text_de = "DE" + let exn_opt = CCOption.get_exn_or "invalid timespan" + + module Time = struct + open Ptime + open Ptime_clock + open Test_utils + + let in_an_hour = add_span (now ()) Model.hour |> exn_opt + let in_two_hours = add_span (now ()) Model.two_hours |> exn_opt + let an_hour_ago = sub_span (now ()) Model.hour |> exn_opt + let two_hours_ago = sub_span (now ()) Model.two_hours |> exn_opt + end + + let start_at = StartAt.create Time.in_an_hour + let end_at = EndAt.create Time.in_two_hours + + let text = + Text.create [ Language.En, text_en; Language.De, text_de ] |> get_exn + ;; + + let show_to_admins = ShowToAdmins.create true + let show_to_contacts = ShowToContacts.create true + + let urlencoded = + [ text_name Language.De, text_de + ; text_name Language.En, text_en + ; Field.(show Start), start_at |> StartAt.value |> Ptime.to_rfc3339 + ; Field.(show End), end_at |> EndAt.value |> Ptime.to_rfc3339 + ; Field.(show ShowToAdmins), "true" + ; Field.(show ShowToContacts), "true" + ] + |> CCList.map (fun (k, v) -> k, [ v ]) + |> Http_utils.format_request_boolean_values boolean_fields + ;; +end + +let create () = + let id = Id.create () in + let create = create ~id in + let tenant_ids = Pool_tenant.[ Id.create () ] in + let run_test ?(tenant_ids = tenant_ids) urlencoded expected msg = + let open CCResult in + let result = + let open Command.Create in + urlencoded |> decode >>= handle ~id tenant_ids + in + Test_utils.check_result ~msg expected result + in + let urlencoded_remove = Test_utils.urlencoded_remove Data.urlencoded in + let urlencoded_update = Test_utils.urlencoded_update Data.urlencoded in + (* CREATE ALL SET *) + let expected = + let open Data in + let announcement = + create text (Some start_at) (Some end_at) show_to_admins show_to_contacts + in + Ok [ Created (announcement, tenant_ids) |> Pool_event.announcement ] + in + let () = run_test Data.urlencoded expected "create all set" in + (* CREATE NO START / NO END *) + let updates key = CCList.mem key Field.[ show Start; show End ] in + let expected = + let open Data in + let announcement = create text None None show_to_admins show_to_contacts in + Ok [ Created (announcement, tenant_ids) |> Pool_event.announcement ] + in + let () = + run_test (urlencoded_remove updates) expected "create no start / no end" + in + (* CREATE START AFTER END *) + let updates = + let open Ptime in + [ ( CCString.equal Field.(show Start) + , add_span (Data.start_at |> StartAt.value) Test_utils.Model.two_hours + |> CCOption.get_exn_or "invalid time" + |> to_rfc3339 ) + ] + in + let expected = Error Error.EndBeforeStart in + let () = + run_test (urlencoded_update updates) expected "create start after end" + in + (* CREATE WITHOUT TEXT *) + let expected = Error (Error.AtLeastOneLanguageRequired Field.Text) in + let updates = CCString.starts_with ~prefix:Field.(show Text) in + let () = + run_test (urlencoded_remove updates) expected "create without text" + in + (* CREATE WITHOUT NO DISPLAY FLAG *) + let expected = + Error Error.(AtLeastOneSelected (Field.ShowToAdmins, Field.ShowToContacts)) + in + let updates key = + CCList.mem key Field.[ show ShowToAdmins; show ShowToContacts ] + in + let () = + run_test (urlencoded_remove updates) expected "create with no display flag" + in + () +;; diff --git a/pool/test/command.ml b/pool/test/command.ml index 3df4d0c96..18c4a25c6 100644 --- a/pool/test/command.ml +++ b/pool/test/command.ml @@ -4,7 +4,8 @@ let () = let open Alcotest in run "cqrs commands" - [ ( "contact" + [ ("announcement", Announcement_test.[ test_case "create" `Quick create ]) + ; ( "contact" , [ test_case "sign up not allowed suffix" `Quick diff --git a/pool/test/test_utils.ml b/pool/test/test_utils.ml index fee674a9c..5395ade62 100644 --- a/pool/test/test_utils.ml +++ b/pool/test/test_utils.ml @@ -3,6 +3,7 @@ module Data = struct end (* Testable *) +let annoncement = Announcement.(Alcotest.testable pp equal) let contact = Contact.(Alcotest.testable pp equal) let database_label = Database.Label.(Alcotest.testable pp equal) let error = Pool_message.Error.(Alcotest.testable pp equal) @@ -46,6 +47,22 @@ let sort_events = CCList.stable_sort Pool_event.(fun a b -> CCString.compare (show a) (show b)) ;; +let urlencoded_update urlencoded updates = + let open CCOption in + CCList.map + (fun (k, v) -> + CCList.find_opt (fun (check, _) -> check k) updates + >|= snd + >|= CCList.return + |> value ~default:v + |> CCPair.make k) + urlencoded +;; + +let urlencoded_remove urlencoded validation = + CCList.filter CCFun.(fst %> validation %> not) urlencoded +;; + let file_to_storage file = let open Seed.Assets in let stored_file = @@ -78,6 +95,27 @@ let dummy_to_file (dummy : Seed.Assets.file) = ;; module Model = struct + let create_announcement + ?id + ?start_at + ?end_at + ?(show_to_admins = true) + ?(show_to_contacts = true) + () + = + let open Announcement in + let text = + Text.create [ Pool_common.Language.En, "text" ] |> get_or_failwith + in + create + ?id + text + start_at + end_at + (ShowToAdmins.create show_to_admins) + (ShowToContacts.create show_to_contacts) + ;; + let password = Pool_user.Password.Plain.( create "Somepassword1!" |> validate |> get_or_failwith) diff --git a/pool/web/handler/root_announcements.ml b/pool/web/handler/root_announcements.ml index 5982f81e8..38bbcdd44 100644 --- a/pool/web/handler/root_announcements.ml +++ b/pool/web/handler/root_announcements.ml @@ -5,6 +5,7 @@ let src = Logs.Src.create "handler.root.announcements" let active_navigation = "/root/announcements" let create_layout = General.create_root_layout let announcement_path = Http_utils.Url.Root.announcement_path +let boolean_fields = Field.[ show ShowToAdmins; show ShowToContacts ] let announcement_id req = Http_utils.get_field_router_param req Field.Announcement @@ -103,11 +104,11 @@ let create req = let events = let open CCResult in let open Cqrs_command.Announcement_command.Create in - let texts = text_from_urlencoded urlencoded in let%lwt tenant_ids = selected_tenants_from_urlencoded req in urlencoded + |> Http_utils.format_request_boolean_values boolean_fields |> decode - >>= handle ~tags:Logs.Tag.empty texts tenant_ids + >>= handle ~tags:Logs.Tag.empty tenant_ids |> Lwt_result.lift in let handle events = @@ -140,11 +141,11 @@ let update req = let events = let open CCResult in let open Cqrs_command.Announcement_command.Update in - let texts = text_from_urlencoded urlencoded in let%lwt tenant_ids = selected_tenants_from_urlencoded req in urlencoded + |> Http_utils.format_request_boolean_values boolean_fields |> decode - >>= handle ~tags:Logs.Tag.empty announcement texts tenant_ids + >>= handle ~tags:Logs.Tag.empty announcement tenant_ids |> Lwt_result.lift in let handle events = From 28fa37034250bc6c059fcbfabcef2d6de1975ffb Mon Sep 17 00:00:00 2001 From: Timo Huber Date: Fri, 11 Oct 2024 07:59:37 +0200 Subject: [PATCH 7/9] emplty line at eof --- resources/index.scss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/resources/index.scss b/resources/index.scss index 1363cb071..1067d1dff 100644 --- a/resources/index.scss +++ b/resources/index.scss @@ -602,4 +602,4 @@ $n: 12; float: none; } } -} \ No newline at end of file +} From 47c72fd00c9735a6a24eda95eb7e3cb3d74ce505 Mon Sep 17 00:00:00 2001 From: Timo Huber Date: Mon, 14 Oct 2024 15:56:44 +0200 Subject: [PATCH 8/9] add integration tests to find current announcement --- pool/app/announcement/announcement.ml | 1 + pool/app/announcement/announcement.mli | 17 ++--- pool/app/announcement/repo/repo.ml | 32 +++++++- pool/test/announcement_test.ml | 100 +++++++++++++++++++++++++ pool/test/integration.ml | 2 + pool/test/integration_utils.ml | 20 +++++ pool/web/handler/public.ml | 4 +- pool/web/handler/root_announcements.ml | 8 +- 8 files changed, 163 insertions(+), 21 deletions(-) diff --git a/pool/app/announcement/announcement.ml b/pool/app/announcement/announcement.ml index d3eba85c2..21fa8426d 100644 --- a/pool/app/announcement/announcement.ml +++ b/pool/app/announcement/announcement.ml @@ -6,3 +6,4 @@ let find = Repo.find let all = Repo.all let find_admin = Repo.find_admin let find_by_user = Repo.find_by_user +let find_of_tenant = Repo.find_of_tenant diff --git a/pool/app/announcement/announcement.mli b/pool/app/announcement/announcement.mli index 0e610d53a..d82d5a111 100644 --- a/pool/app/announcement/announcement.mli +++ b/pool/app/announcement/announcement.mli @@ -80,23 +80,20 @@ val create type admin = t * Pool_tenant.t list -val find - : Database.Label.t - -> Id.t - -> (t, Pool_message__Pool_message_error.t) result Lwt.t - +val find : Id.t -> (t, Pool_message__Pool_message_error.t) Lwt_result.t val all : ?query:Query.t -> Database.Label.t -> (t list * Query.t) Lwt.t - -val find_admin - : Database.Label.t - -> Id.t - -> (admin, Pool_message.Error.t) Lwt_result.t +val find_admin : Id.t -> (admin, Pool_message.Error.t) Lwt_result.t val find_by_user : Database.Label.t -> [< `Admin | `Contact ] * Pool_common.Id.t -> t option Lwt.t +val find_of_tenant + : Database.Label.t + -> Id.t + -> (t, Pool_message.Error.t) Lwt_result.t + val column_start : Query.Column.t val column_end : Query.Column.t val filterable_by : Query.Filter.human option diff --git a/pool/app/announcement/repo/repo.ml b/pool/app/announcement/repo/repo.ml index 2ed308b70..b950cbb05 100644 --- a/pool/app/announcement/repo/repo.ml +++ b/pool/app/announcement/repo/repo.ml @@ -166,9 +166,9 @@ let find_request = |> Pool_common.Repo.Id.t ->! Repo_entity.t ;; -let find pool id = +let find id = let open Utils.Lwt_result.Infix in - Database.find_opt pool find_request id + Database.find_opt Database.root find_request id ||> CCOption.to_result Pool_message.(Error.NotFound Field.Announcement) ;; @@ -176,13 +176,35 @@ let all ?query pool = Query.collect_and_count pool query ~select:find_request_sql Repo_entity.t ;; -let find_admin pool id = +let find_admin id = let open Utils.Lwt_result.Infix in - let* announcement = find pool id in + let pool = Database.root in + let* announcement = find id in let* tenants = TenantMapping.find_tenants_by_announcement pool id in Lwt_result.return (announcement, tenants) ;; +let find_on_tenant_request = + let open Caqti_request.Infix in + {sql| + INNER JOIN pool_announcement_tenants ON pool_announcements.uuid = pool_announcement_tenants.pool_announcement_uuid + INNER JOIN pool_tenant ON pool_announcement_tenants.pool_tenant_uuid = pool_tenant.uuid + WHERE + pool_tenant.database_label = $1 + AND + pool_announcements.uuid = UNHEX(REPLACE($2, '-', '')) + |sql} + |> find_request_sql + |> Caqti_type.(t2 Database.Repo.Label.t Pool_common.Repo.Id.t) + ->! Repo_entity.t +;; + +let find_of_tenant database_label id = + let open Utils.Lwt_result.Infix in + Database.find_opt Database.root find_on_tenant_request (database_label, id) + ||> CCOption.to_result Pool_message.(Error.NotFound Field.Announcement) +;; + let find_by_user_request context = let open Caqti_request.Infix in let where = @@ -204,6 +226,8 @@ let find_by_user_request context = AND(pool_announcements.end_at > NOW() OR pool_announcements.end_at IS NULL) AND pool_announcement_users_hide.user_users_uuid IS NULL + ORDER BY pool_announcements.start_at ASC + LIMIT 1 |sql} where |> find_request_sql diff --git a/pool/test/announcement_test.ml b/pool/test/announcement_test.ml index 6b325b45c..815c22d6d 100644 --- a/pool/test/announcement_test.ml +++ b/pool/test/announcement_test.ml @@ -114,3 +114,103 @@ let create () = in () ;; + +let find_current _ () = + let open Utils.Lwt_result.Infix in + let open Integration_utils in + let pool = Database.root in + let%lwt tenant = + Pool_tenant.find_by_label Test_utils.Data.database_label ||> get_exn + in + let tenand_db = tenant.Pool_tenant.database_label in + let%lwt as_contat = + let open Contact in + ContactRepo.create () ||> id ||> Id.to_common ||> CCPair.make `Contact + in + let%lwt as_admin = + let open Admin in + AdminRepo.create () ||> id ||> Id.to_common ||> CCPair.make `Admin + in + let tenant_id = tenant.Pool_tenant.id in + let id = Id.create () in + let%lwt announcement = AnnouncementRepo.create ~id [ tenant_id ] in + let run_test ?(tenants = [ tenant_id ]) announcement context found msg = + let%lwt () = Updated (announcement, tenants) |> handle_event pool in + let%lwt expected = + match found with + | false -> Lwt.return_none + | true -> find_of_tenant tenand_db id ||> get_exn ||> CCOption.return + in + let%lwt res = find_by_user tenand_db context in + Alcotest.(check (option Test_utils.annoncement) msg expected res) + |> Lwt.return + in + (* GET WITHOUT START / END *) + let%lwt () = run_test announcement as_admin true "get without start / end" in + let%lwt () = + let m = + { announcement with + show_to_admins = ShowToAdmins.create false + ; show_to_contacts = ShowToContacts.create true + } + in + let msg = Format.asprintf "no start/end, hidden from admins, as %s" in + let%lwt () = run_test m as_admin false (msg "contact") in + let%lwt () = run_test m as_contat true (msg "admin") in + Lwt.return_unit + in + (* GET WITH PAST START *) + let%lwt () = + let start_at = StartAt.create Data.Time.two_hours_ago in + let m = { announcement with start_at = Some start_at } in + let msg = "get with past start" in + let%lwt () = run_test m as_admin true msg in + let%lwt () = run_test m as_contat true msg in + Lwt.return_unit + in + (* GET WITH FUTURE START *) + let%lwt () = + let start_at = StartAt.create Data.Time.in_two_hours in + let m = { announcement with start_at = Some start_at } in + let msg = "get with future start" in + let%lwt () = run_test m as_admin false msg in + let%lwt () = run_test m as_contat false msg in + Lwt.return_unit + in + (* GET WITH START AND END *) + let%lwt () = + let start_at = StartAt.create Data.Time.two_hours_ago in + let end_at = EndAt.create Data.Time.in_an_hour in + let m = + { announcement with start_at = Some start_at; end_at = Some end_at } + in + let msg = Format.asprintf "get with past start and future end, as %s" in + let%lwt () = run_test m as_admin true (msg "admin") in + let%lwt () = run_test m as_contat true (msg "user") in + Lwt.return_unit + in + (* ON DIFFERENT TENANT *) + let%lwt () = + let msg = Format.asprintf "on different tenant, as %s" in + let%lwt () = + run_test ~tenants:[] announcement as_admin false (msg "admin") + in + let%lwt () = + run_test ~tenants:[] announcement as_contat false (msg "contact") + in + Lwt.return_unit + in + (* MARK AS READ *) + let%lwt () = + let msg = "mark as read" in + let%lwt () = + [ snd as_admin; snd as_contat ] + |> CCList.map (fun id -> Hidden (announcement, id)) + |> Lwt_list.iter_s (handle_event pool) + in + let%lwt () = run_test announcement as_admin false msg in + let%lwt () = run_test announcement as_contat false msg in + Lwt.return_unit + in + Lwt.return_unit +;; diff --git a/pool/test/integration.ml b/pool/test/integration.ml index c8c05e490..412dfc9f1 100644 --- a/pool/test/integration.ml +++ b/pool/test/integration.ml @@ -52,6 +52,8 @@ let suite = `Slow Admin_role_assignment.grant_roles ] ) + ; ( "announcement" + , Announcement_test.[ test_case "find current" `Slow find_current ] ) ; ( "partial_update" , Partial_update. [ test_case "update with old version" `Slow update_with_old_version diff --git a/pool/test/integration_utils.ml b/pool/test/integration_utils.ml index 4184506c3..ac4a54b3a 100644 --- a/pool/test/integration_utils.ml +++ b/pool/test/integration_utils.ml @@ -1,5 +1,25 @@ open Test_utils +module AnnouncementRepo = struct + let create ?id ?start_at ?end_at ?show_to_admins ?show_to_contacts tenant_ids = + let announcement = + Test_utils.Model.create_announcement + ?id + ?start_at + ?end_at + ?show_to_admins + ?show_to_contacts + () + in + let%lwt () = + Announcement.Created (announcement, tenant_ids) + |> Pool_event.announcement + |> Pool_event.handle_event Database.root + in + Lwt.return announcement + ;; +end + module AssignmentRepo = struct let create ?id session contact = let assignment = Assignment.create ?id contact in diff --git a/pool/web/handler/public.ml b/pool/web/handler/public.ml index e7b11ecee..fec85c5d8 100644 --- a/pool/web/handler/public.ml +++ b/pool/web/handler/public.ml @@ -244,13 +244,13 @@ let terms_and_conditions req = let hide_announcement req = let open Http_utils in - let result { Pool_context.user; _ } = + let result { Pool_context.user; database_label; _ } = let open Utils.Lwt_result.Infix in let open Announcement in let* announcement = find_id Id.validate Field.Announcement req |> Lwt_result.lift - >>= find Database.root + >>= find_of_tenant database_label in let* () = Cqrs_command.Announcement_command.Hide.handle (user, announcement) diff --git a/pool/web/handler/root_announcements.ml b/pool/web/handler/root_announcements.ml index 38bbcdd44..c247b34d0 100644 --- a/pool/web/handler/root_announcements.ml +++ b/pool/web/handler/root_announcements.ml @@ -60,7 +60,7 @@ let index req = ;; let form case req = - let result ({ Pool_context.database_label; _ } as context) = + let result context = Lwt_result.map_error (fun err -> err, announcement_path ()) @@ let flash_fetcher key = Sihl.Web.Flash.find key req in @@ -70,9 +70,7 @@ let form case req = match case with | `New -> Lwt_result.return None | `Edit -> - announcement_id req - |> Announcement.find_admin database_label - >|+ CCOption.return + announcement_id req |> Announcement.find_admin >|+ CCOption.return in Page.Root.Announcement.form context @@ -137,7 +135,7 @@ let update req = , announcement_path ~id ~suffix:"edit" () , [ Http_utils.urlencoded_to_flash urlencoded ] )) @@ - let* announcement = Announcement.find database_label id in + let* announcement = Announcement.find id in let events = let open CCResult in let open Cqrs_command.Announcement_command.Update in From f15f38963d50ab10b2714a249bc0e21bf5776123 Mon Sep 17 00:00:00 2001 From: Timo Huber Date: Tue, 15 Oct 2024 16:46:28 +0200 Subject: [PATCH 9/9] resolve mr discussion --- pool/app/announcement/announcement.ml | 7 +------ .../migrations/migration_202309211305.ml | 1 - .../migrations/migration_202410031211.ml | 13 ++++++++++++- resources/index.scss | 2 -- 4 files changed, 13 insertions(+), 10 deletions(-) diff --git a/pool/app/announcement/announcement.ml b/pool/app/announcement/announcement.ml index 21fa8426d..f02251f3a 100644 --- a/pool/app/announcement/announcement.ml +++ b/pool/app/announcement/announcement.ml @@ -1,9 +1,4 @@ include Entity include Event include Entity_guard - -let find = Repo.find -let all = Repo.all -let find_admin = Repo.find_admin -let find_by_user = Repo.find_by_user -let find_of_tenant = Repo.find_of_tenant +include Repo diff --git a/pool/app/pool_database/migrations/migration_202309211305.ml b/pool/app/pool_database/migrations/migration_202309211305.ml index 8918e539f..6e4ba6117 100644 --- a/pool/app/pool_database/migrations/migration_202309211305.ml +++ b/pool/app/pool_database/migrations/migration_202309211305.ml @@ -95,7 +95,6 @@ let add_default_guardian_role_permission_root = {sql| INSERT INTO `guardian_role_permissions` (`role`, `permission`, `target_model`) VALUES ('`Operator', 'manage', '`Admin'), - ('`Operator', 'manage', '`Announcement'), ('`Operator', 'manage', '`Assignment'), ('`Operator', 'manage', '`Contact'), ('`Operator', 'manage', '`ContactInfo'), diff --git a/pool/app/pool_database/migrations/migration_202410031211.ml b/pool/app/pool_database/migrations/migration_202410031211.ml index 21b89b7aa..2502a4788 100644 --- a/pool/app/pool_database/migrations/migration_202410031211.ml +++ b/pool/app/pool_database/migrations/migration_202410031211.ml @@ -53,10 +53,21 @@ let create_pool_announcement_users_hide_table = |sql} ;; +let add_guardian_role_permission = + Database.Migration.Step.create + ~label:"add default guardian role permissions" + {sql| + INSERT INTO `guardian_role_permissions` (`role`, `permission`, `target_model`) VALUES + ('`Operator', 'manage', '`Announcement') + ON DUPLICATE KEY UPDATE updated_at=updated_at + |sql} +;; + let migration () = Database.Migration.( empty "202410031211" |> add_step create_pool_announcements_table |> add_step create_pool_announcement_tenants_table - |> add_step create_pool_announcement_users_hide_table) + |> add_step create_pool_announcement_users_hide_table + |> add_step add_guardian_role_permission) ;; diff --git a/resources/index.scss b/resources/index.scss index 1067d1dff..0691c31a0 100644 --- a/resources/index.scss +++ b/resources/index.scss @@ -584,8 +584,6 @@ $n: 12; grid-column: 1; } - -// ANNOUNCEMENT .announcement { .close { float: right;