Feature/86 announcement banner (#445)

* add announcement CRUD

* allow selection of tenants

* add option to display to contacts and admin

* display announcement on tenants

* allow banners to be hidden

* add test case

* emplty line at eof

* add integration tests to find current announcement

* resolve mr discussion

---------

Co-authored-by: Timo Huber <[email protected]>

pool/app/announcement/announcement.ml

@@ -0,0 +1,4 @@
+include Entity
+include Event
+include Entity_guard
+include Repo

pool/app/announcement/announcement.mli

@@ -0,0 +1,132 @@
+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
+
+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
+  }
+
+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 sexp_of_t : t -> Sexplib.Sexp.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
+
+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 : 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
+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 * 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
+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

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)

pool/app/announcement/entity.ml

@@ -0,0 +1,124 @@
+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
+;;
+
+let equal_ptime a b = Sihl.Configuration.is_test () || Ptime.equal a b
+
+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
+  ;;
+
+  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
+  include Pool_model.Base.Ptime
+
+  let create m = m
+  let schema () = ptime_schema Pool_message.Field.Start
+  let equal = equal_ptime
+end
+
+module EndAt = struct
+  include Pool_model.Base.Ptime
+
+  let create m = m
+  let schema () = ptime_schema Pool_message.Field.End
+  let equal = equal_ptime
+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 sexp_of_t { id; _ } = Id.sexp_of_t id
+
+let create
+  ?(id = Id.create ())
+  text
+  start_at
+  end_at
+  show_to_admins
+  show_to_contacts
+  =
+  { id
+  ; text
+  ; start_at
+  ; end_at
+  ; show_to_admins
+  ; show_to_contacts
+  ; created_at = Pool_common.CreatedAt.create_now ()
+  ; updated_at = Pool_common.UpdatedAt.create_now ()
+  }
+;;
+
+type admin = t * Pool_tenant.t list [@@deriving eq, show]
+
+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 ()

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

pool/app/announcement/event.ml

@@ -0,0 +1,22 @@
+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 =
+  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) (fst m)
+      ||> Pool_common.Utils.get_or_failwith
+      ||> fun (_ : Guard.Target.t) -> ()
+    in
+    Lwt.return_unit
+  | Updated m -> Repo.update pool m
+  | Hidden (m, user_id) -> Repo.hide user_id m
+;;