Feature/1859 improve session close screen

CHANGELOG.md

@@ -4,6 +4,18 @@ The format is based on [Keep a Changelog](http://keepachangelog.com/) and this p
 
 ## [unreleased](https://github.com/uzh/pool/tree/HEAD)
 
+### Added
+
+- added edit form assignments of closed sessions
+
+### Changed
+
+- session close screen updates assignments on change
+
+### Fixed
+
+- filtering by multiple experiment participations
+
 ## [0.4.4](https://github.com/uzh/pool/tree/0.4.4) - 2023-08-10
 
 ### Added

pool/app/assignment/assignment.ml

@@ -3,6 +3,7 @@ include Event
 module Guard = Entity_guard
 
 let find = Repo.find
+let find_closed = Repo.find_closed
 
 let find_upcoming_by_experiment_and_contact_opt =
   Repo.find_by_experiment_and_contact_opt `Upcoming
@@ -38,3 +39,35 @@ let group_by_contact list =
     list;
   Hashtbl.fold (fun contact lst acc -> (contact, lst) :: acc) tbl []
 ;;
+
+type session_counters =
+  { total : int
+  ; num_no_shows : int
+  ; num_participations : int
+  }
+
+let init_session_counters =
+  { total = 0; num_no_shows = 0; num_participations = 0 }
+;;
+
+let assignments_to_session_counters =
+  CCList.fold_left
+    (fun { total; num_no_shows; num_participations }
+         ({ no_show; participated; _ } : t) ->
+      let default = CCOption.value ~default:false in
+      { total = total + 1
+      ; num_no_shows =
+          (if default no_show then num_no_shows + 1 else num_no_shows)
+      ; num_participations =
+          (if default participated
+           then num_participations + 1
+           else num_participations)
+      })
+    init_session_counters
+;;
+
+let counters_of_session database_label session_id =
+  let open Utils.Lwt_result.Infix in
+  find_uncanceled_by_session database_label session_id
+  >|+ assignments_to_session_counters
+;;

pool/app/assignment/assignment.mli

@@ -64,7 +64,7 @@ val create
   -> Contact.t
   -> t
 
-val is_not_closed : t -> (unit, Pool_common.Message.error) result
+val is_not_closed : Session.t -> (unit, Pool_common.Message.error) result
 val is_deletable : t -> (unit, Pool_common.Message.error) result
 val is_cancellable : t -> (unit, Pool_common.Message.error) result
 val attendance_settable : t -> (unit, Pool_common.Message.error) result
@@ -83,11 +83,35 @@ module IncrementParticipationCount : sig
   val create : bool -> t
 end
 
+val validate
+  :  Experiment.t
+  -> t
+  -> (unit, Pool_common.Message.error list) result
+
+val set_close_default_values : t -> t * NoShow.t * Participated.t
+val boolean_fields : Pool_common.Message.Field.t list
+
+type session_counters =
+  { total : int
+  ; num_no_shows : int
+  ; num_participations : int
+  }
+
+val counters_of_session
+  :  Pool_database.Label.t
+  -> Session.Id.t
+  -> (session_counters, Pool_common.Message.error) result Lwt.t
+
 val find
   :  Pool_database.Label.t
   -> Id.t
   -> (t, Pool_common.Message.error) result Lwt.t
 
+val find_closed
+  :  Pool_database.Label.t
+  -> Id.t
+  -> (t, Pool_common.Message.error) result Lwt.t
+
 val find_upcoming_by_experiment_and_contact_opt
   :  Pool_database.Label.t
   -> Experiment.Id.t
@@ -130,23 +154,19 @@ val find_follow_ups : Pool_database.Label.t -> t -> t list Lwt.t
 
 val contact_participation_in_other_assignments
   :  Pool_database.Label.t
-  -> t list
+  -> exclude_assignments:t list
   -> Experiment.Id.t
   -> Contact.Id.t
   -> (bool, Pool_common.Message.error) Lwt_result.t
 
 val group_by_contact : t list -> (Contact.t * t list) list
 
 type event =
-  | AttendanceSet of (t * NoShow.t * Participated.t * ExternalDataId.t option)
   | Canceled of t
   | Created of (t * Session.Id.t)
   | MarkedAsDeleted of t
   | ExternalDataIdUpdated of t * ExternalDataId.t option
-
-val attendanceset
-  :  t * NoShow.t * Participated.t * ExternalDataId.t option
-  -> event
+  | Updated of t
 
 val canceled : t -> event
 val created : t * Session.Id.t -> event

pool/app/assignment/entity.ml

@@ -90,8 +90,8 @@ let is_not_deleted { marked_as_deleted; _ } =
   else Error Pool_common.Message.(IsMarkedAsDeleted Field.Assignment)
 ;;
 
-let is_not_closed { no_show; participated; _ } =
-  if CCOption.(is_none no_show && is_none participated)
+let is_not_closed { Session.closed_at; canceled_at; _ } =
+  if CCOption.(is_none closed_at && is_none canceled_at)
   then Ok ()
   else Error Pool_common.Message.AssignmentIsClosed
 ;;
@@ -135,3 +135,31 @@ module IncrementParticipationCount = struct
   let value m = m
   let create m = m
 end
+
+let validate experiment { no_show; participated; external_data_id; _ } =
+  let value = CCOption.value ~default:false in
+  let open Pool_common.Message in
+  [ ( Experiment.external_data_required_value experiment
+      && CCOption.is_none external_data_id
+      && value participated
+    , FieldRequired Field.ExternalDataId )
+  ; ( value no_show && value participated
+    , MutuallyExclusive (Field.NoShow, Field.Participated) )
+  ]
+  |> CCList.filter_map (fun (condition, error) ->
+    if condition then Some error else None)
+  |> function
+  | [] -> Ok ()
+  | errors -> Error errors
+;;
+
+let set_close_default_values ({ no_show; participated; _ } as m) =
+  let default = CCOption.value ~default:false in
+  let no_show = default no_show in
+  let participated = default participated in
+  ( { m with no_show = Some no_show; participated = Some participated }
+  , no_show
+  , participated )
+;;
+
+let boolean_fields = Pool_common.Message.Field.[ NoShow; Participated ]

pool/app/assignment/event.ml

@@ -1,21 +1,14 @@
 open Entity
 
 type event =
-  | AttendanceSet of (t * NoShow.t * Participated.t * ExternalDataId.t option)
   | Canceled of t
   | Created of (t * Session.Id.t)
   | MarkedAsDeleted of t
   | ExternalDataIdUpdated of t * ExternalDataId.t option
+  | Updated of t
 [@@deriving eq, show, variants]
 
 let handle_event pool : event -> unit Lwt.t = function
-  | AttendanceSet (assignment, no_show, participated, external_data_id) ->
-    { assignment with
-      participated = Some participated
-    ; no_show = Some no_show
-    ; external_data_id
-    }
-    |> Repo.update pool
   | Canceled assignment ->
     let%lwt () =
       (* TODO: Check timestamps? Issue #126 *)
@@ -35,4 +28,5 @@ let handle_event pool : event -> unit Lwt.t = function
   | MarkedAsDeleted assignment -> assignment.id |> Repo.marked_as_deleted pool
   | ExternalDataIdUpdated (assignment, external_data_id) ->
     { assignment with external_data_id } |> Repo.update pool
+  | Updated t -> Repo.update pool t
 ;;

pool/app/assignment/repo/repo.ml

@@ -85,7 +85,31 @@ module Sql = struct
       (Pool_database.Label.value pool)
       find_request
       (Pool_common.Id.value id)
-    ||> CCOption.to_result Pool_common.Message.(NotFound Field.Tenant)
+    ||> CCOption.to_result Pool_common.Message.(NotFound Field.Assignment)
+  ;;
+
+  let find_closed_request =
+    let joins =
+      {sql|
+        INNER JOIN pool_sessions ON pool_sessions.uuid = pool_assignments.session_uuid
+      |sql}
+    in
+    let open Caqti_request.Infix in
+    {sql|
+        pool_assignments.uuid = UNHEX(REPLACE(?, '-', ''))
+        AND pool_sessions.closed_at IS NOT NULL
+    |sql}
+    |> select_sql ~joins
+    |> Caqti_type.string ->! RepoEntity.t
+  ;;
+
+  let find_closed pool id =
+    let open Utils.Lwt_result.Infix in
+    Utils.Database.find_opt
+      (Pool_database.Label.value pool)
+      find_closed_request
+      (Pool_common.Id.value id)
+    ||> CCOption.to_result Pool_common.Message.(NotFound Field.Assignment)
   ;;
 
   let find_by_session_request ?where_condition () =
@@ -275,7 +299,7 @@ module Sql = struct
       (Pool_database.Label.value pool)
       find_session_id_request
       id
-    ||> CCOption.to_result Pool_common.Message.(NotFound Field.Experiment)
+    ||> CCOption.to_result Pool_common.Message.(NotFound Field.Session)
   ;;
 
   let insert_request =
@@ -407,11 +431,11 @@ module Sql = struct
 
   let contact_participation_in_other_assignments
     pool
-    assignments
+    ~exclude_assignments
     experiment_uuid
     contact_uuid
     =
-    if CCList.is_empty assignments
+    if CCList.is_empty exclude_assignments
     then Lwt_result.fail Pool_common.Message.InvalidRequest
     else
       let open Caqti_request.Infix in
@@ -427,11 +451,11 @@ module Sql = struct
           (fun dyn { Entity.id; _ } ->
             dyn |> add string (id |> Entity.Id.value))
           init
-          assignments
+          exclude_assignments
       in
       let (Pack (pt, pv)) = dyn in
       let request =
-        contact_participation_in_other_assignments_request assignments
+        contact_participation_in_other_assignments_request exclude_assignments
         |> pt ->! bool
       in
       Utils.Database.find (pool |> Pool_database.Label.value) request pv
@@ -450,6 +474,11 @@ let find pool id =
   Sql.find pool id >>= contact_to_assignment pool
 ;;
 
+let find_closed pool id =
+  let open Utils.Lwt_result.Infix in
+  Sql.find_closed pool id >>= contact_to_assignment pool
+;;
+
 let uncanceled_condition = "pool_assignments.canceled_at IS NULL"
 
 let find_by_session filter pool id =

pool/app/contact/contact.mli

@@ -93,6 +93,7 @@ val id : t -> Pool_common.Id.t
 val firstname : t -> Pool_user.Firstname.t
 val lastname : t -> Pool_user.Lastname.t
 val fullname : t -> string
+val lastname_firstname : t -> string
 val email_address : t -> Pool_user.EmailAddress.t
 val sexp_of_t : t -> Sexplib0.Sexp.t
 val show : t -> string

pool/app/contact/entity.ml

@@ -144,14 +144,15 @@ let id m = m.user.Sihl_user.id |> Pool_common.Id.of_string
 let fullname m = m.user |> User.user_fullname
 let firstname m = m.user |> User.user_firstname
 let lastname m = m.user |> User.user_lastname
+let lastname_firstname m = m.user |> User.user_lastname_firstname
 let email_address m = m.user.Sihl_user.email |> User.EmailAddress.of_string
 
 let sexp_of_t t =
   t |> id |> Pool_common.Id.value |> fun s -> Sexplib0.Sexp.Atom s
 ;;
 
 let update_num_invitations ~step ({ num_invitations; _ } as m) =
-  { m with num_assignments = NumberOfInvitations.update step num_invitations }
+  { m with num_invitations = NumberOfInvitations.update step num_invitations }
 ;;
 
 let update_num_assignments ~step ({ num_assignments; _ } as m) =

pool/app/contact/repo/repo_model.ml

@@ -320,11 +320,11 @@ module Write = struct
                                       (tup2
                                          NumberOfAssignments.t
                                          (tup2
-                                            NumberOfAssignments.t
+                                            NumberOfShowUps.t
                                             (tup2
-                                               NumberOfShowUps.t
+                                               NumberOfNoShows.t
                                                (tup2
-                                                  NumberOfNoShows.t
+                                                  NumberOfParticipations.t
                                                   (tup2
                                                      Pool_common.Repo.Version.t
                                                      (tup2

pool/app/contact_counter/contact_counter.ml

@@ -70,3 +70,30 @@ let update_on_assignment_deletion
   then Contact.update_num_participations ~step:(-1) contact
   else contact
 ;;
+
+let update_on_assignment_update
+  { Assignment.contact; _ }
+  current_no_show
+  updated_no_show
+  participated_in_other_assignments
+  =
+  let open Contact in
+  let value = Assignment.NoShow.value in
+  let update_participation_count ~step =
+    if participated_in_other_assignments
+    then CCFun.id
+    else update_num_participations ~step
+  in
+  match current_no_show |> value, updated_no_show |> value with
+  | true, false ->
+    contact
+    |> update_num_no_shows ~step:(-1)
+    |> update_num_show_ups ~step:1
+    |> update_participation_count ~step:1
+  | false, true ->
+    contact
+    |> update_num_no_shows ~step:1
+    |> update_num_show_ups ~step:(-1)
+    |> update_participation_count ~step:(-1)
+  | true, true | false, false -> contact
+;;

pool/app/contact_counter/contact_counter.mli

@@ -21,3 +21,10 @@ val update_on_assignment_deletion
   -> Contact.t
   -> Assignment.IncrementParticipationCount.t
   -> Contact.t
+
+val update_on_assignment_update
+  :  Assignment.t
+  -> Assignment.NoShow.t
+  -> Assignment.NoShow.t
+  -> bool
+  -> Contact.t

pool/app/pool_common/entity_i18n.ml

@@ -1,6 +1,8 @@
 type t =
   | Address
   | AdminComment
+  | AssignmentEditTagsWarning
+  | AssignmentListEmpty
   | AvailableSpots
   | Canceled
   | Closed
@@ -205,6 +207,7 @@ type confirmable =
   | CancelAssignment
   | CancelAssignmentWithFollowUps
   | CancelSession
+  | CloseSession
   | DeleteCustomField
   | DeleteCustomFieldOption
   | DeleteEmailSuffix