Feature/matcher online surveys (#436)

* update container package * update lockfile * send invitations for online studies if future time window exists * remove logs * add test cases * extend test case to cover max_participants * uncomment cleanup * make test path unique * reset exception messages * fix start survey buttom text * reset matcher * only send invitations if future sessions exist * refactor query * update test * resolve mr discussion * remove comment --------- Co-authored-by: Timo Huber <[email protected]>
uzh · Sep 30, 2024 · 78ac0bb · 78ac0bb
1 parent 3868b53
commit 78ac0bb
Show file tree

Hide file tree

Showing 21 changed files with 360 additions and 141 deletions.
diff --git a/pool/app/experiment/repo/repo_public.ml b/pool/app/experiment/repo/repo_public.ml
@@ -27,6 +27,13 @@ let select_from_experiments_sql ?(distinct = false) where_fragment =
   Format.asprintf "%s %s" select_from where_fragment
 ;;
 
+let pool_sessions_inner_join =
+  {sql|
+    INNER JOIN pool_sessions 
+    ON pool_sessions.experiment_uuid = pool_experiments.uuid
+  |sql}
+;;
+
 let pool_invitations_left_join =
   {sql|
       LEFT OUTER JOIN pool_invitations
@@ -40,10 +47,9 @@ let condition_registration_not_disabled =
 ;;
 
 let condition_allow_uninvited_signup =
-  Format.asprintf
-    {sql|
-      pool_experiments.allow_uninvited_signup = 1
-    |sql}
+  {sql|
+    pool_experiments.allow_uninvited_signup = 1
+  |sql}
 ;;
 
 let assignments_base_condition ~require_participated =
@@ -82,36 +88,31 @@ let find_upcoming_to_register_request experiment_type () =
   let open Caqti_request.Infix in
   let onsite_session_exists =
     {sql|
-      AND EXISTS (SELECT
-        1
-      FROM
-        pool_sessions
-      WHERE
-        pool_sessions.experiment_uuid = pool_experiments.uuid
-      AND pool_sessions.start > NOW())
+      (pool_sessions.start > NOW()
+        AND
+      pool_sessions.canceled_at IS NULL)
     |sql}
   in
   let timewindow_exists =
     {sql|
-      AND EXISTS (
-        SELECT
-          1
-        FROM
-          pool_sessions
-        WHERE
-          pool_sessions.experiment_uuid = pool_experiments.uuid
-          AND pool_sessions.start < NOW()
-          AND DATE_ADD(pool_sessions.start, INTERVAL pool_sessions.duration SECOND) > NOW())
-      |sql}
+      (DATE_ADD(pool_sessions.start, INTERVAL pool_sessions.duration SECOND) > NOW()
+        AND 
+      pool_sessions.canceled_at IS NULL)
+    |sql}
   in
-  let experiment_type, session_condition, assignment_condition =
+  let experiment_type, session_condition, assignment_condition, order_by =
     let type_condition =
       Format.asprintf
         {sql| pool_experiments.assignment_without_session = %s |sql}
     in
     match experiment_type with
-    | `Online -> type_condition "1", timewindow_exists, condition_participated
-    | `OnSite -> type_condition "0", onsite_session_exists, condition_assigned
+    | `Online ->
+      ( type_condition "1"
+      , timewindow_exists
+      , condition_participated
+      , "ORDER BY pool_sessions.start" )
+    | `OnSite ->
+      type_condition "0", onsite_session_exists, condition_assigned, ""
   in
   let not_on_waitinglist =
     {sql|
@@ -128,8 +129,11 @@ let find_upcoming_to_register_request experiment_type () =
       )
       |sql}
   in
+  (* TODO: make those subqueries joins (#2248) *)
   Format.asprintf
-    "%s WHERE %s AND %s AND %s AND %s AND (%s OR %s) %s"
+    "%s %s WHERE %s AND %s AND %s AND %s AND (%s OR %s) AND %s GROUP BY \
+     pool_experiments.uuid %s"
+    pool_sessions_inner_join
     pool_invitations_left_join
     experiment_type
     ("NOT " ^ assignment_condition)
@@ -138,6 +142,7 @@ let find_upcoming_to_register_request experiment_type () =
     condition_allow_uninvited_signup
     condition_is_invited
     session_condition
+    order_by
   |> Repo.find_request_sql
   |> Contact.Repo.Id.t ->* RepoEntity.t
 ;;

diff --git a/pool/app/pool_common/entity_i18n.ml b/pool/app/pool_common/entity_i18n.ml
@@ -28,6 +28,10 @@ type t =
   | ExperimentListPublicTitle
   | ExperimentOnlineListEmpty
   | ExperimentOnlineListPublicTitle
+  | ExperimentOnlineParticiated of Ptime.t
+  | ExperimentOnlineParticipationDeadline of Ptime.t
+  | ExperimentOnlineParticipationNoUpcoming
+  | ExperimentOnlineParticipationUpcoming of Ptime.t
   | ExperimentListTitle
   | ExperimentMessagingSubtitle
   | ExperimentNewTitle
@@ -254,7 +258,6 @@ type hint =
   | NumberMax of int
   | NumberMin of int
   | OnlineExperiment
-  | OnlineExperimentParticipationDeadline of Ptime.t
   | Overbook
   | PartialUpdate
   | ParticipationTagsHint

diff --git a/pool/app/pool_common/locales/i18n_de.ml b/pool/app/pool_common/locales/i18n_de.ml
@@ -53,6 +53,22 @@ let to_string = function
   | ExperimentOnlineListEmpty ->
     "Aktuell gibt es keine Onlinestudien, an denen Sie teilnehmen können."
   | ExperimentOnlineListPublicTitle -> "Verfügbare Onlinestudien"
+  | ExperimentOnlineParticipationDeadline end_at ->
+    Format.asprintf
+      "Sie können noch bis zum %s an diesem Experiment teilnehmen."
+      (Pool_model.Time.formatted_date_time end_at)
+  | ExperimentOnlineParticiated submitted ->
+    Format.asprintf
+      "Sie haben diese Umfrage am %s abgeschlossen."
+      (Utils.Ptime.formatted_date submitted)
+  | ExperimentOnlineParticipationUpcoming start_at ->
+    Format.asprintf
+      "Das nächste Zeitfenster für die Teilnahme an dieser Umfrage beginnt am \
+       %s."
+      (Pool_model.Time.formatted_date_time start_at)
+  | ExperimentOnlineParticipationNoUpcoming ->
+    "Es sind zur Zeit keine weiteren Zeitfenster für die Teilnahme an dieser \
+     Umfrage geplant."
   | ExperimentListTitle -> "Experimente"
   | ExperimentMessagingSubtitle -> "Identitäten"
   | ExperimentNewTitle -> "Neues Experiment erstellen"
@@ -535,10 +551,6 @@ Scheduled: Es läuft kein Mailing, aber zukünftige Mailings sind geplant|}
        externe URL der Studie an, auf welche die Kontakte weitergeleitet \
        werden sollen."
       (Locales_de.field_to_string Pool_message.Field.SurveyUrl)
-  | OnlineExperimentParticipationDeadline end_at ->
-    Format.asprintf
-      "Sie können noch bis zum %s an diesem Experiment teilnehmen."
-      (Pool_model.Time.formatted_date_time end_at)
   | Overbook ->
     "Anzahl Kontakte, die sich zusätzlich zur maximalen Anzahl Teilnehmer, an \
      einer Session einschreiben können."

diff --git a/pool/app/pool_common/locales/i18n_en.ml b/pool/app/pool_common/locales/i18n_en.ml
@@ -53,6 +53,21 @@ let to_string = function
   | ExperimentOnlineListEmpty ->
     "Currently, there are no online surveys you can participate in."
   | ExperimentOnlineListPublicTitle -> "Available online surveys"
+  | ExperimentOnlineParticiated submitted ->
+    Format.asprintf
+      "You completed this survey on %s."
+      (Utils.Ptime.formatted_date submitted)
+  | ExperimentOnlineParticipationDeadline end_at ->
+    Format.asprintf
+      "You can participate in this experiment until %s."
+      (Pool_model.Time.formatted_date_time end_at)
+  | ExperimentOnlineParticipationUpcoming start_at ->
+    Format.asprintf
+      "The next window for participation in this survey begins on %s."
+      (Pool_model.Time.formatted_date_time start_at)
+  | ExperimentOnlineParticipationNoUpcoming ->
+    "There are currently no further time windows for participation in this \
+     survey are planned."
   | ExperimentListTitle -> "Experiments"
   | ExperimentMessagingSubtitle -> "Identities"
   | ExperimentNewTitle -> "Create new experiment"
@@ -517,10 +532,6 @@ Scheduled: No mailing is running, but future mailings are scheduled.|}
        part in the survey. Under %s, enter the external URL of the survey to \
        which the contacts should be forwarded."
       (Locales_en.field_to_string Pool_message.Field.SurveyUrl)
-  | OnlineExperimentParticipationDeadline end_at ->
-    Format.asprintf
-      "You can participate in this experiment until %s."
-      (Pool_model.Time.formatted_date_time end_at)
   | Overbook ->
     "Number of subjects that can enroll in a session in addition to the \
      maximum number of contacts."

diff --git a/pool/app/session/dune b/pool/app/session/dune
@@ -6,6 +6,7 @@
    lwt_ppx
    ppx_deriving.eq
    ppx_deriving.show
+   ppx_string
    ppx_variants_conv
    ppx_yojson_conv)))
 

diff --git a/pool/app/session/repo/repo.ml b/pool/app/session/repo/repo.ml
@@ -248,11 +248,12 @@ module Sql = struct
     >|> find_multiple pool
   ;;
 
-  let find_all_for_experiment_request =
+  let find_all_for_experiment_request ?(where = "") () =
     let open Caqti_request.Infix in
-    {sql|
-      WHERE pool_sessions.experiment_uuid = UNHEX(REPLACE(?, '-', ''))
-    |sql}
+    [%string
+      {sql|
+      WHERE pool_sessions.experiment_uuid = %{Entity.Id.sql_value_fragment "?"} %{where}
+    |sql}]
     |> find_request_sql
     |> order_by_start
     |> Caqti_type.string ->* RepoEntity.t
@@ -261,7 +262,15 @@ module Sql = struct
   let find_all_for_experiment pool id =
     Database.collect
       pool
-      find_all_for_experiment_request
+      (find_all_for_experiment_request ())
+      (Experiment.Id.value id)
+  ;;
+
+  let find_upcoming_for_experiment pool id =
+    let where = {sql| AND pool_sessions.start > NOW() |sql} in
+    Database.collect
+      pool
+      (find_all_for_experiment_request ~where ())
       (Experiment.Id.value id)
   ;;
 

diff --git a/pool/app/session/session.ml b/pool/app/session/session.ml
@@ -3,6 +3,7 @@ include Event
 module Guard = Entity_guard
 
 let find_all_for_experiment = Repo.find_all_for_experiment
+let find_upcoming_for_experiment = Repo.Sql.find_upcoming_for_experiment
 
 let find_all_to_assign_from_waitinglist =
   Repo.find_all_to_assign_from_waitinglist

diff --git a/pool/app/session/session.mli b/pool/app/session/session.mli
@@ -281,6 +281,11 @@ val find_all_for_experiment
   -> Experiment.Id.t
   -> t list Lwt.t
 
+val find_upcoming_for_experiment
+  :  Database.Label.t
+  -> Experiment.Id.t
+  -> t list Lwt.t
+
 val find_all_to_assign_from_waitinglist
   :  Database.Label.t
   -> Experiment.Id.t

diff --git a/pool/app/time_window/event.ml b/pool/app/time_window/event.ml
@@ -12,6 +12,7 @@ type create =
 type event =
   | Created of t
   | Updated of t
+  | Deleted of t
 [@@deriving eq, show]
 
 let handle_event pool =
@@ -25,4 +26,5 @@ let handle_event pool =
     ||> Pool_common.Utils.get_or_failwith
     ||> fun (_ : Guard.Target.t) -> ()
   | Updated time_window -> Repo.update pool time_window
+  | Deleted time_window -> Repo.delete pool time_window
 ;;
diff --git a/pool/app/time_window/repo/repo.ml b/pool/app/time_window/repo/repo.ml
@@ -153,6 +153,19 @@ let update pool =
   RepoEntity.Write.of_entity %> Database.exec pool update_request
 ;;
 
+let delete_request =
+  let open Caqti_request.Infix in
+  {sql|
+      DELETE FROM pool_sessions
+      WHERE uuid = UNHEX(REPLACE(?, '-', ''))
+  |sql}
+  |> Session.Repo.Id.t ->. Caqti_type.unit
+;;
+
+let delete pool time_window =
+  Database.exec pool delete_request time_window.Entity.id
+;;
+
 let query_by_experiment ?query pool id =
   let where =
     let sql =
@@ -169,24 +182,48 @@ let query_by_experiment ?query pool id =
     Repo_entity.t
 ;;
 
-let find_current_by_experiment_request =
+let find_by_experiment_and_time_request time =
   let open Caqti_request.Infix in
-  {sql|
-      WHERE
-        pool_experiments.uuid = UNHEX(REPLACE($1, '-', ''))
-        AND pool_sessions.start < NOW()
-        AND DATE_ADD(pool_sessions.start, INTERVAL pool_sessions.duration SECOND) > NOW()
-        AND pool_sessions.canceled_at IS NULL
-    |sql}
-  |> find_request_sql
+  let where, limit =
+    match time with
+    | `Current ->
+      let where =
+        {sql|
+          pool_experiments.uuid = UNHEX(REPLACE($1, '-', ''))
+          AND pool_sessions.start < NOW()
+          AND DATE_ADD(pool_sessions.start, INTERVAL pool_sessions.duration SECOND) > NOW()
+          AND pool_sessions.canceled_at IS NULL
+        |sql}
+      in
+      where, ""
+    | `Upcoming ->
+      let where =
+        {sql|
+          pool_experiments.uuid = UNHEX(REPLACE($1, '-', ''))
+          AND DATE_ADD(pool_sessions.start, INTERVAL pool_sessions.duration SECOND) > NOW()
+          AND pool_sessions.canceled_at IS NULL
+        |sql}
+      in
+      let limit =
+        {sql|
+          ORDER BY pool_sessions.start ASC
+          LIMIT 1 
+        |sql}
+      in
+      where, limit
+  in
+  Format.asprintf
+    "SELECT %s FROM pool_sessions %s WHERE %s GROUP BY pool_sessions.uuid %s"
+    (CCString.concat ", " sql_select_columns)
+    joins
+    where
+    limit
   |> Pool_common.Repo.Id.t ->! RepoEntity.t
 ;;
 
-let find_current_by_experiment pool experiment_id =
-  let open Utils.Lwt_result.Infix in
+let find_by_experiment_and_time time pool experiment_id =
   Database.find_opt
     pool
-    find_current_by_experiment_request
+    (find_by_experiment_and_time_request time)
     (Experiment.Id.to_common experiment_id)
-  ||> CCOption.to_result Pool_message.(Error.NotFound Field.TimeWindow)
 ;;
diff --git a/pool/app/time_window/time_window.ml b/pool/app/time_window/time_window.ml
@@ -4,4 +4,5 @@ include Event
 let find = Repo.find
 let find_overlapping = Repo.find_overlapping
 let query_by_experiment = Repo.query_by_experiment
-let find_current_by_experiment = Repo.find_current_by_experiment
+let find_current_by_experiment = Repo.find_by_experiment_and_time `Current
+let find_upcoming_by_experiment = Repo.find_by_experiment_and_time `Upcoming
diff --git a/pool/app/time_window/time_window.mli b/pool/app/time_window/time_window.mli
@@ -50,6 +50,7 @@ type create =
 type event =
   | Created of t
   | Updated of t
+  | Deleted of t
 
 val handle_event : Database.Label.t -> event -> unit Lwt.t
 val equal_event : event -> event -> bool
@@ -78,4 +79,9 @@ val query_by_experiment
 val find_current_by_experiment
   :  Database.Label.t
   -> Experiment.Id.t
-  -> (t, Pool_message.Error.t) Lwt_result.t
+  -> t option Lwt.t
+
+val find_upcoming_by_experiment
+  :  Database.Label.t
+  -> Experiment.Id.t
+  -> t option Lwt.t
diff --git a/pool/matcher/matcher.ml b/pool/matcher/matcher.ml
@@ -80,16 +80,16 @@ let experiment_has_bookable_spots
   let open Session in
   match CCOption.is_some online_experiment with
   | false ->
-    find_all_for_experiment database_label id
+    find_upcoming_for_experiment database_label id
     ||> CCList.filter (fun session ->
       CCOption.is_none session.follow_up_to && not (is_fully_booked session))
     ||> CCList.is_empty
     ||> not
   | true ->
-    Time_window.find_current_by_experiment database_label id
+    Time_window.find_upcoming_by_experiment database_label id
     ||> (function
-     | Error _ -> false
-     | Ok { Time_window.max_participants; participant_count; _ } ->
+     | None -> false
+     | Some { Time_window.max_participants; participant_count; _ } ->
        max_participants
        |> CCOption.map_or ~default:true (fun max_participants ->
          ParticipantAmount.value max_participants