add integration tests to find current announcement

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

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

pool/app/announcement/repo/repo.ml

@@ -166,23 +166,45 @@ 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)
 ;;
 
 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

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

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

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

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)

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