diff --git a/CHANGELOG.md b/CHANGELOG.md
index d300beee3..b967b18f9 100644
--- a/CHANGELOG.md
+++ b/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
diff --git a/pool/app/assignment/assignment.ml b/pool/app/assignment/assignment.ml
index 8d6d706da..72bc4a514 100644
--- a/pool/app/assignment/assignment.ml
+++ b/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
+;;
diff --git a/pool/app/assignment/assignment.mli b/pool/app/assignment/assignment.mli
index 36108cc91..7969eb448 100644
--- a/pool/app/assignment/assignment.mli
+++ b/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,7 +154,7 @@ 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
@@ -138,15 +162,11 @@ val contact_participation_in_other_assignments
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
diff --git a/pool/app/assignment/entity.ml b/pool/app/assignment/entity.ml
index 016670c98..f33b28e7a 100644
--- a/pool/app/assignment/entity.ml
+++ b/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 ]
diff --git a/pool/app/assignment/event.ml b/pool/app/assignment/event.ml
index dc821afe1..a608ea73e 100644
--- a/pool/app/assignment/event.ml
+++ b/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
;;
diff --git a/pool/app/assignment/repo/repo.ml b/pool/app/assignment/repo/repo.ml
index 3c5e84419..08e4d8d46 100644
--- a/pool/app/assignment/repo/repo.ml
+++ b/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 =
diff --git a/pool/app/contact/contact.mli b/pool/app/contact/contact.mli
index 805112d3f..3918c9e0f 100644
--- a/pool/app/contact/contact.mli
+++ b/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
diff --git a/pool/app/contact/entity.ml b/pool/app/contact/entity.ml
index 17e778e26..8680f70dd 100644
--- a/pool/app/contact/entity.ml
+++ b/pool/app/contact/entity.ml
@@ -144,6 +144,7 @@ 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 =
@@ -151,7 +152,7 @@ let sexp_of_t t =
;;
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) =
diff --git a/pool/app/contact/repo/repo_model.ml b/pool/app/contact/repo/repo_model.ml
index 8e8b239ac..2a61b15fb 100644
--- a/pool/app/contact/repo/repo_model.ml
+++ b/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
diff --git a/pool/app/contact_counter/contact_counter.ml b/pool/app/contact_counter/contact_counter.ml
index bd3fbaf3e..a71b71343 100644
--- a/pool/app/contact_counter/contact_counter.ml
+++ b/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
+;;
diff --git a/pool/app/contact_counter/contact_counter.mli b/pool/app/contact_counter/contact_counter.mli
index 65f921380..333264694 100644
--- a/pool/app/contact_counter/contact_counter.mli
+++ b/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
diff --git a/pool/app/pool_common/entity_i18n.ml b/pool/app/pool_common/entity_i18n.ml
index 510652794..8729c344a 100644
--- a/pool/app/pool_common/entity_i18n.ml
+++ b/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
diff --git a/pool/app/pool_common/entity_message.ml b/pool/app/pool_common/entity_message.ml
index 35744a691..11e69a18f 100644
--- a/pool/app/pool_common/entity_message.ml
+++ b/pool/app/pool_common/entity_message.ml
@@ -27,6 +27,7 @@ type error =
| AlreadyStarted
| AssignmentIsCanceled
| AssignmentIsClosed
+ | AssignmentsHaveErrors
| Authorization of string
| CannotBeDeleted of Field.t
| Conformist of (Field.t * error) list
@@ -99,6 +100,7 @@ type error =
| Retrieve of Field.t
| SessionAlreadyCanceled of string
| SessionAlreadyClosed of string
+ | SessionNotClosed
| SessionFullyBooked
| SessionHasAssignments
| SessionHasFollowUps
@@ -212,6 +214,7 @@ type control =
| MarkAsDeleted
| More
| NextPage
+ | OpenProfile
| PauseAccount
| PleaseSelect
| PreviousPage
@@ -219,8 +222,8 @@ type control =
| Publish of Field.t option
| ReactivateAccount
| Register
- | RemoveFromWaitingList
| Remove of Field.t option
+ | RemoveFromWaitingList
| Reschedule of Field.t option
| Resend of Field.t option
| Reset
diff --git a/pool/app/pool_common/entity_message_field.ml b/pool/app/pool_common/entity_message_field.ml
index b68ce4cea..ed8193be7 100644
--- a/pool/app/pool_common/entity_message_field.ml
+++ b/pool/app/pool_common/entity_message_field.ml
@@ -263,6 +263,7 @@ type t =
| TimeSpan [@name "timespan"] [@printer go "timespan"]
| Title [@name "title"] [@printer go "title"]
| Token [@name "token"] [@printer go "token"]
+ | Total [@name "total"] [@printer go "total"]
| Translation [@name "translation"] [@printer go "translation"]
| Tries [@name "tries"] [@printer go "tries"]
| TriggerProfileUpdateAfter [@name "trigger_profile_update_after"]
diff --git a/pool/app/pool_common/locales/i18n_de.ml b/pool/app/pool_common/locales/i18n_de.ml
index bc9d7ad67..4e25f782e 100644
--- a/pool/app/pool_common/locales/i18n_de.ml
+++ b/pool/app/pool_common/locales/i18n_de.ml
@@ -3,6 +3,12 @@ open Entity_i18n
let to_string = function
| Address -> "Addresse"
| AdminComment -> "Administrator Kommentar"
+ | AssignmentEditTagsWarning ->
+ "Bitte beachten Sie, dass durch die Bearbeitung der Anmeldung keine Tags \
+ zugewiesen oder entfernt werden, die durch die Teilnahme an dieser \
+ Session dem Kontakt zugewiesen wurden. Wenn dies erforderlich ist, wenden \
+ Sie sich bitte an eine Person mit den erforderlichen Berechtigungen."
+ | AssignmentListEmpty -> "Es existieren keine Anmeldungen für diese Session."
| AvailableSpots -> "Freie Plätze"
| Canceled -> "Abgesagt"
| Closed -> "Geschlossen"
@@ -370,11 +376,17 @@ Die folgenden Folgesessions existieren:|}
"Es wurden keine Tags ausgewählt, die den Teilnehmer/innen zugewiesen \
werden, die an diesem Experiment teilgenommen haben."
| SessionCloseHints ->
- {|NS und P schliessen sich gegenseitig aus.
+ Format.asprintf
+ {|%s und %s schliessen sich gegenseitig aus.
Wenn ein Kontakt zwar erschienen ist, aber nicht an dem Experiment teilgenommen hat, wählen Sie keine der Optionen aus.|}
+ (Locales_de.field_to_string Entity_message_field.NoShow)
+ (Locales_de.field_to_string Entity_message_field.Participated)
| SessionCloseLegend ->
- {|NS: Der Kontakt ist nicht an der Session erschienen
- P: Der Kontakt hat am Experiment teilgenommen|}
+ Format.asprintf
+ {|%s: Der Kontakt ist nicht an der Session erschienen
+ %s: Der Kontakt hat am Experiment teilgenommen|}
+ (Locales_de.field_to_string Entity_message_field.NoShow)
+ (Locales_de.field_to_string Entity_message_field.Participated)
| SessionReminderLanguageHint ->
"Falls sie einen eigenen Erinnerungstext angeben, wählen Sie dessen \
Sprache hier."
@@ -418,6 +430,10 @@ let confirmable_to_string confirmable =
, "annulieren"
, Some "Anmeldungen an Folgesession werden ebenfalls annuliert." )
| CancelSession -> "die Session", "absagen", None
+ | CloseSession ->
+ ( "die Session"
+ , "schliessen"
+ , Some "Diese Aktion kann nicht rückgängig gemacht werden." )
| DeleteCustomField -> "das Feld", "löschen", None
| DeleteCustomFieldOption -> "das Option", "löschen", None
| DeleteEmailSuffix -> "das Suffix", "löschen", None
diff --git a/pool/app/pool_common/locales/i18n_en.ml b/pool/app/pool_common/locales/i18n_en.ml
index 0865d68e7..1e5f651d9 100644
--- a/pool/app/pool_common/locales/i18n_en.ml
+++ b/pool/app/pool_common/locales/i18n_en.ml
@@ -1,8 +1,16 @@
open Entity_i18n
+let capitalize = CCString.capitalize_ascii
+
let to_string = function
| Address -> "address"
| AdminComment -> "admin comment"
+ | AssignmentEditTagsWarning ->
+ "Please note that editing the assignment does not assign or remove any \
+ tags that may have been assigned by participating in this session from \
+ the contact. If this is required, please a person with the necessary \
+ permissions."
+ | AssignmentListEmpty -> "There are no assignments for this session."
| AvailableSpots -> "Available spots"
| Canceled -> "Canceled"
| Closed -> "Closed"
@@ -354,12 +362,20 @@ The following follow-up sessions exist:|}
"No tags were selected to be assigned to the participants who participated \
in this experiment."
| SessionCloseHints ->
- {|NS and P are mutually exclusive.
-If a contact showed up but did not participate in the experiment, do not select any of the options.|}
+ Format.asprintf
+ {|%s and %s are mutually exclusive.
+ If a contact showed up but did not participate in the experiment, do not select any of the options.|}
+ (Locales_en.field_to_string Entity_message_field.NoShow |> capitalize)
+ (Locales_en.field_to_string Entity_message_field.Participated
+ |> capitalize)
| SessionCloseLegend ->
- {|NS: the contact did not show up
- P: the contact participated in the experiment
+ Format.asprintf
+ {|%s: the contact did not show up
+ %s: the contact participated in the experiment
|}
+ (Locales_en.field_to_string Entity_message_field.NoShow |> capitalize)
+ (Locales_en.field_to_string Entity_message_field.Participated
+ |> capitalize)
| SearchByFields fields ->
Format.asprintf
"Search by: %s"
@@ -401,6 +417,7 @@ let confirmable_to_string confirmable =
, "cancel"
, Some "Assignments to follow-up sessions will be canceled as well." )
| CancelSession -> "session", "cancel", None
+ | CloseSession -> "session", "close", Some "This action cannot be undone."
| DeleteCustomField -> "field", "delete", None
| DeleteCustomFieldOption -> "option", "delete", None
| DeleteEmailSuffix -> "email suffix", "delete", None
diff --git a/pool/app/pool_common/locales/locales_de.ml b/pool/app/pool_common/locales/locales_de.ml
index 7953e9f25..de8bc77d9 100644
--- a/pool/app/pool_common/locales/locales_de.ml
+++ b/pool/app/pool_common/locales/locales_de.ml
@@ -224,6 +224,7 @@ let rec field_to_string =
| TimeSpan -> "Zeitspanne"
| Title -> "Titel"
| Token -> "Token"
+ | Total -> "Total"
| Translation -> "Übersetzung"
| Tries -> "Versuche"
| TriggerProfileUpdateAfter -> "Aufforderung zur Kontrolle des Profils"
@@ -338,6 +339,8 @@ let rec error_to_string = function
"wurde bereits veröffentlich."
| AssignmentIsCanceled -> "Anmeldung wurde abgesagt."
| AssignmentIsClosed -> "Anmeldung wurde bereits geschlossen."
+ | AssignmentsHaveErrors ->
+ "Einige Anmeldungen haben Fehler. Bitte korrigieren Sie diese zuerst."
| AlreadyStarted ->
"Bereits gestarted oder beendet, aktion nicht mehr möglich."
| AlreadyInvitedToExperiment names ->
@@ -515,6 +518,7 @@ let rec error_to_string = function
CCFormat.asprintf "Diese Session wurde bereits abgesagt am %s." date
| SessionAlreadyClosed date ->
CCFormat.asprintf "Diese Session wurde bereits geschlossen am %s." date
+ | SessionNotClosed -> "Diese Session wurde noch nicht geschlossen."
| SessionInPast -> "Diese Session ist beendet."
| SessionNotStarted -> "Diese Session kann noch nicht geschlossen werden."
| Smaller (field1, field2) ->
@@ -577,6 +581,7 @@ let control_to_string = function
| MarkAsDeleted -> format_submit "als gelöscht markieren" None
| More -> "mehr"
| NextPage -> "weiter"
+ | OpenProfile -> "Profil anzeigen"
| PauseAccount -> "Account pausieren"
| PleaseSelect -> "bitte wählen"
| PreviousPage -> "zurück"
diff --git a/pool/app/pool_common/locales/locales_en.ml b/pool/app/pool_common/locales/locales_en.ml
index 245ddbeb6..fc56d7fec 100644
--- a/pool/app/pool_common/locales/locales_en.ml
+++ b/pool/app/pool_common/locales/locales_en.ml
@@ -225,6 +225,7 @@ let rec field_to_string =
| TimeSpan -> "time span"
| Title -> "title"
| Token -> "token"
+ | Total -> "total"
| Translation -> "translation"
| Tries -> "tries"
| TriggerProfileUpdateAfter -> "request to check the profile"
@@ -328,6 +329,8 @@ let rec error_to_string = function
"You are already signed up for this experiment."
| AssignmentIsCanceled -> "Assignment was canceled."
| AssignmentIsClosed -> "Assignment is already closed."
+ | AssignmentsHaveErrors ->
+ "Some assignments have errors. Please resolve them first."
| AlreadyStarted -> "Already started or ended, action not possible anymore."
| AlreadyInvitedToExperiment names ->
Format.asprintf
@@ -410,7 +413,7 @@ let rec error_to_string = function
"is missing or not filled out."
| MutuallyExclusive (f1, f2) ->
Format.asprintf
- "%s and %s are mutually exclusive."
+ "'%s' and '%s' are mutually exclusive."
(field_to_string f1)
(field_to_string f2)
| NegativeAmount -> "Has negative amount!"
@@ -478,6 +481,7 @@ let rec error_to_string = function
CCFormat.asprintf "This session has already been canceled on %s." date
| SessionAlreadyClosed date ->
CCFormat.asprintf "This session has already been closed at %s." date
+ | SessionNotClosed -> "This session has not been closed yet."
| SessionInPast -> "This session has already finished."
| SessionNotStarted -> "This session cannot be closed, yet."
| SessionRegistrationViaParent -> "Registration via main session."
@@ -540,6 +544,7 @@ let control_to_string = function
| MarkAsDeleted -> format_submit "mark as deleted" None
| More -> format_submit "more" None
| NextPage -> "next"
+ | OpenProfile -> "show profile"
| PauseAccount -> format_submit "pause account" None
| PleaseSelect -> format_submit "please select" None
| PreviousPage -> "previous"
diff --git a/pool/app/pool_user/entity.ml b/pool/app/pool_user/entity.ml
index be5eddbc5..22440f096 100644
--- a/pool/app/pool_user/entity.ml
+++ b/pool/app/pool_user/entity.ml
@@ -312,4 +312,11 @@ let user_fullname user =
(user |> user_lastname |> Lastname.value)
;;
+let user_lastname_firstname user =
+ Format.asprintf
+ "%s %s"
+ (user |> user_lastname |> Lastname.value)
+ (user |> user_firstname |> Firstname.value)
+;;
+
let user_email_address user = user.Sihl_user.email |> EmailAddress.of_string
diff --git a/pool/app/pool_user/pool_user.mli b/pool/app/pool_user/pool_user.mli
index c91c0581b..fc4dda27d 100644
--- a/pool/app/pool_user/pool_user.mli
+++ b/pool/app/pool_user/pool_user.mli
@@ -215,6 +215,7 @@ end
val user_firstname : Sihl_user.t -> Firstname.t
val user_lastname : Sihl_user.t -> Lastname.t
val user_fullname : Sihl_user.t -> string
+val user_lastname_firstname : Sihl_user.t -> string
val user_email_address : Sihl_user.t -> EmailAddress.t
module FailedLoginAttempt : sig
diff --git a/pool/app/session/entity.ml b/pool/app/session/entity.ml
index 99b9c3415..38154d477 100644
--- a/pool/app/session/entity.ml
+++ b/pool/app/session/entity.ml
@@ -529,15 +529,11 @@ let is_deletable session follow_ups =
| false, false -> Ok ()
;;
-(* Closable if after session ends *)
let is_closable session =
let open CCResult.Infix in
- let open Pool_common.Message in
let* () = not_closed session in
let* () = not_canceled session in
- if Ptime.is_earlier session.start ~than:Ptime_clock.(now ())
- then Ok ()
- else Error SessionNotStarted
+ Ok ()
;;
let assignments_cancelable session =
diff --git a/pool/cqrs_command/assignment_command.ml b/pool/cqrs_command/assignment_command.ml
index e01c3f3bb..0a95cea2b 100644
--- a/pool/cqrs_command/assignment_command.ml
+++ b/pool/cqrs_command/assignment_command.ml
@@ -3,6 +3,33 @@ open CCFun.Infix
let src = Logs.Src.create "assignment.cqrs"
+type update =
+ { no_show : Assignment.NoShow.t
+ ; participated : Assignment.Participated.t
+ ; external_data_id : Assignment.ExternalDataId.t option
+ }
+
+let update_command no_show participated external_data_id =
+ { no_show; participated; external_data_id }
+;;
+
+let update_schema =
+ let open Assignment in
+ Conformist.(
+ make
+ Field.
+ [ NoShow.schema ()
+ ; Participated.schema ()
+ ; Conformist.optional @@ ExternalDataId.schema ()
+ ]
+ update_command)
+;;
+
+let decode_update data =
+ Conformist.decode_and_validate update_schema data
+ |> CCResult.map_err Pool_common.Message.to_conformist_error
+;;
+
let assignment_effect action id =
let open Guard in
ValidationSet.One
@@ -144,126 +171,6 @@ end = struct
let effects = Assignment.Guard.Access.delete
end
-module SetAttendance : sig
- type t =
- (Assignment.t
- * Assignment.NoShow.t
- * Assignment.Participated.t
- * Assignment.IncrementParticipationCount.t
- * Assignment.t list option
- * Assignment.ExternalDataId.t option)
- list
-
- val handle
- : ?tags:Logs.Tag.set
- -> Experiment.t
- -> Session.t
- -> Tags.t list
- -> t
- -> (Pool_event.t list, Pool_common.Message.error) result
-
- val effects : Experiment.Id.t -> Session.Id.t -> Guard.ValidationSet.t
-end = struct
- type t =
- (Assignment.t
- * Assignment.NoShow.t
- * Assignment.Participated.t
- * Assignment.IncrementParticipationCount.t
- * Assignment.t list option
- * Assignment.ExternalDataId.t option)
- list
-
- let handle
- ?(tags = Logs.Tag.empty)
- experiment
- (session : Session.t)
- (participation_tags : Tags.t list)
- (command : t)
- =
- Logs.info ~src (fun m -> m "Handle command SetAttendance" ~tags);
- let open CCResult in
- let open Assignment in
- let open Session in
- let* () = Session.is_closable session in
- CCList.fold_left
- (fun events participation ->
- events
- >>= fun events ->
- participation
- |> fun ( ({ contact; _ } as assignment : Assignment.t)
- , no_show
- , participated
- , increment_num_participaton
- , follow_ups
- , external_data_id ) ->
- let cancel_followups =
- NoShow.value no_show || not (Participated.value participated)
- in
- let* () = attendance_settable assignment in
- let* contact =
- Contact_counter.update_on_session_closing
- contact
- no_show
- participated
- increment_num_participaton
- in
- let num_assignments_decrement, mark_as_deleted =
- let open CCList in
- match cancel_followups, follow_ups with
- | true, Some follow_ups ->
- let num_assignments =
- follow_ups
- |> filter (fun assignment ->
- CCOption.is_none assignment.Assignment.canceled_at)
- %> length
- in
- let marked_as_deleted =
- follow_ups >|= markedasdeleted %> Pool_event.assignment
- in
- num_assignments, marked_as_deleted
- | _, _ -> 0, []
- in
- let* external_data_id =
- match
- Experiment.external_data_required_value experiment, external_data_id
- with
- | true, None ->
- Error Pool_common.Message.(FieldRequired Field.ExternalDataId)
- | _, _ -> Ok external_data_id
- in
- let contact =
- Contact.update_num_assignments
- ~step:(CCInt.neg num_assignments_decrement)
- contact
- in
- let tag_events =
- let open Tags in
- match participated |> Participated.value with
- | false -> []
- | true ->
- participation_tags
- |> CCList.map (fun (tag : t) ->
- Tagged
- Tagged.{ model_uuid = Contact.id contact; tag_uuid = tag.id }
- |> Pool_event.tags)
- in
- let contact_events =
- (Contact.Updated contact |> Pool_event.contact) :: mark_as_deleted
- in
- events
- @ ((Assignment.AttendanceSet
- (assignment, no_show, participated, external_data_id)
- |> Pool_event.assignment)
- :: contact_events)
- @ tag_events
- |> CCResult.return)
- (Ok [ Closed session |> Pool_event.session ])
- command
- ;;
-
- let effects = Session.Guard.Access.update
-end
-
module CreateFromWaitingList : sig
include Common.CommandSig
@@ -375,3 +282,71 @@ end = struct
let effects = Assignment.Guard.Access.delete
end
+
+module UpdateClosed : sig
+ type t = update
+
+ val handle
+ : ?tags:Logs.Tag.set
+ -> Experiment.t
+ -> Session.t
+ -> Assignment.t
+ -> bool
+ -> t
+ -> (Pool_event.t list, Pool_common.Message.error) result
+
+ val decode
+ : (string * string list) list
+ -> (t, Pool_common.Message.error) result
+end = struct
+ type t = update
+
+ let handle
+ ?(tags = Logs.Tag.empty)
+ (experiment : Experiment.t)
+ { Session.closed_at; _ }
+ ({ Assignment.no_show; participated; _ } as assignment)
+ participated_in_other_assignments
+ (command : update)
+ =
+ Logs.info ~src (fun m -> m "Handle command UpdateClosed" ~tags);
+ let open CCResult in
+ let open Assignment in
+ let* current_no_show =
+ match CCOption.is_some closed_at, no_show, participated with
+ | true, Some no_show, Some _ -> Ok no_show
+ | _ -> Error Pool_common.Message.SessionNotClosed
+ in
+ let contact_counters =
+ Contact_counter.update_on_assignment_update
+ assignment
+ current_no_show
+ command.no_show
+ participated_in_other_assignments
+ |> Contact.updated
+ |> Pool_event.contact
+ in
+ let updated_assignment =
+ { assignment with
+ no_show = Some command.no_show
+ ; participated = Some command.participated
+ ; external_data_id = command.external_data_id
+ }
+ in
+ let* () =
+ validate experiment updated_assignment
+ |> function
+ | Ok () | Error [] -> Ok ()
+ | Error (hd :: _) -> Error hd
+ in
+ Ok
+ [ Assignment.Updated updated_assignment |> Pool_event.assignment
+ ; contact_counters
+ ]
+ ;;
+
+ let decode data =
+ Conformist.decode_and_validate update_schema data
+ |> CCResult.map_err Pool_common.Message.to_conformist_error
+ ;;
+end
diff --git a/pool/cqrs_command/session_command.ml b/pool/cqrs_command/session_command.ml
index 67bfb3d0b..224338246 100644
--- a/pool/cqrs_command/session_command.ml
+++ b/pool/cqrs_command/session_command.ml
@@ -434,7 +434,7 @@ end = struct
in
let* (_ : unit list) =
let open CCList in
- assignments >|= snd |> flatten >|= Assignment.is_not_closed |> all_ok
+ sessions >|= Assignment.is_not_closed |> all_ok
in
let contact_events =
assignments
@@ -496,6 +496,115 @@ end = struct
let effects = Session.Guard.Access.update
end
+module Close : sig
+ type t =
+ (Assignment.t
+ * Assignment.IncrementParticipationCount.t
+ * Assignment.t list option)
+ list
+
+ val handle
+ : ?tags:Logs.Tag.set
+ -> Experiment.t
+ -> Session.t
+ -> Tags.t list
+ -> t
+ -> (Pool_event.t list, Pool_common.Message.error) result
+
+ val effects : Experiment.Id.t -> Session.Id.t -> Guard.ValidationSet.t
+end = struct
+ type t =
+ (Assignment.t
+ * Assignment.IncrementParticipationCount.t
+ * Assignment.t list option)
+ list
+
+ let handle
+ ?(tags = Logs.Tag.empty)
+ experiment
+ (session : Session.t)
+ (participation_tags : Tags.t list)
+ (command : t)
+ =
+ Logs.info ~src (fun m -> m "Handle command SetAttendance" ~tags);
+ let open CCResult in
+ let open Assignment in
+ let open Session in
+ let* () = Session.is_closable session in
+ CCList.fold_left
+ (fun events participation ->
+ events
+ >>= fun events ->
+ participation
+ |> fun ( ({ contact; _ } as assignment : Assignment.t)
+ , increment_num_participaton
+ , follow_ups ) ->
+ let assignment, no_show, participated =
+ set_close_default_values assignment
+ in
+ let* () =
+ validate experiment assignment
+ |> CCResult.map_err
+ (CCFun.const Pool_common.Message.AssignmentsHaveErrors)
+ in
+ let cancel_followups =
+ NoShow.value no_show || not (Participated.value participated)
+ in
+ let* () = attendance_settable assignment in
+ let* contact =
+ Contact_counter.update_on_session_closing
+ contact
+ no_show
+ participated
+ increment_num_participaton
+ in
+ let num_assignments_decrement, mark_as_deleted =
+ let open CCList in
+ match cancel_followups, follow_ups with
+ | true, Some follow_ups ->
+ let num_assignments =
+ follow_ups
+ |> filter (fun assignment ->
+ CCOption.is_none assignment.Assignment.canceled_at)
+ %> length
+ in
+ let marked_as_deleted =
+ follow_ups >|= markedasdeleted %> Pool_event.assignment
+ in
+ num_assignments, marked_as_deleted
+ | _, _ -> 0, []
+ in
+ let contact =
+ Contact.update_num_assignments
+ ~step:(CCInt.neg num_assignments_decrement)
+ contact
+ in
+ let tag_events =
+ let open Tags in
+ match participated |> Participated.value with
+ | false -> []
+ | true ->
+ participation_tags
+ |> CCList.map (fun (tag : t) ->
+ Tagged
+ Tagged.{ model_uuid = Contact.id contact; tag_uuid = tag.id }
+ |> Pool_event.tags)
+ in
+ let contact_events =
+ (Contact.Updated contact |> Pool_event.contact) :: mark_as_deleted
+ in
+ events
+ @ ((Assignment.Updated assignment |> Pool_event.assignment)
+ :: contact_events)
+ @ tag_events
+ |> CCResult.return)
+ (Ok [ Closed session |> Pool_event.session ])
+ command
+ ;;
+
+ let effects = Session.Guard.Access.update
+end
+
module SendReminder : sig
include
Common.CommandSig
diff --git a/pool/routes/routes.ml b/pool/routes/routes.ml
index 1f56f3ef9..33b15461e 100644
--- a/pool/routes/routes.ml
+++ b/pool/routes/routes.ml
@@ -364,6 +364,9 @@ module Admin = struct
let open Experiments.Assignment in
let specific =
[ post "/cancel" ~middlewares:[ Access.cancel ] cancel
+ ; post "/close" ~middlewares:[ Session.Access.close ] close_htmx
+ ; get "/edit" ~middlewares:[ Access.update ] edit
+ ; post "" ~middlewares:[ Access.update ] update
; post
"/mark-as-deleted"
~middlewares:[ Access.mark_as_deleted ]
diff --git a/pool/test/assignment_test.ml b/pool/test/assignment_test.ml
index b7934d784..7fd660071 100644
--- a/pool/test/assignment_test.ml
+++ b/pool/test/assignment_test.ml
@@ -1,6 +1,7 @@
open Test_utils
module ContactCommand = Cqrs_command.Contact_command
module AssignmentCommand = Cqrs_command.Assignment_command
+module SessionCommand = Cqrs_command.Session_command
module Field = Pool_common.Message.Field
type assignment_data =
@@ -132,23 +133,17 @@ let canceled_with_closed_session () =
let set_attendance () =
let open Assignment in
let experiment = Model.create_experiment () in
- let assignment = Model.create_assignment () in
+ let assignment =
+ Model.create_assignment ~no_show:false ~participated:false ()
+ in
let session = Model.(create_session ~start:(an_hour_ago ()) ()) in
- let no_show = false |> NoShow.create in
- let participated = false |> Participated.create in
let increment_num_participaton = IncrementParticipationCount.create false in
let events =
- AssignmentCommand.SetAttendance.handle
+ SessionCommand.Close.handle
experiment
session
[]
- [ ( assignment
- , no_show
- , participated
- , increment_num_participaton
- , None
- , None )
- ]
+ [ assignment, increment_num_participaton, None ]
in
let expected =
let updated_contact =
@@ -160,8 +155,7 @@ let set_attendance () =
in
Ok
[ Session.Closed session |> Pool_event.session
- ; Assignment.AttendanceSet (assignment, no_show, participated, None)
- |> Pool_event.assignment
+ ; Assignment.Updated assignment |> Pool_event.assignment
; updated_contact
]
in
@@ -171,29 +165,58 @@ let set_attendance () =
let set_invalid_attendance () =
let open Assignment in
let experiment = Model.create_experiment () in
- let assignment = Model.create_assignment () in
+ let assignment =
+ Model.create_assignment ~no_show:true ~participated:true ()
+ in
let session = Model.(create_session ~start:(an_hour_ago ()) ()) in
- let no_show = true |> NoShow.create in
- let participated = true |> Participated.create in
let events =
- AssignmentCommand.SetAttendance.handle
+ SessionCommand.Close.handle
experiment
session
[]
- [ ( assignment
- , no_show
- , participated
- , IncrementParticipationCount.create false
- , None
- , None )
- ]
- in
- let expected =
- Error Pool_common.Message.(MutuallyExclusive Field.(Participated, NoShow))
+ [ assignment, IncrementParticipationCount.create false, None ]
in
+ let expected = Error Pool_common.Message.AssignmentsHaveErrors in
check_result expected events
;;
+let assignment_validation () =
+ let check_result expected generated =
+ Alcotest.(
+ check (result unit (list Test_utils.error)) "succeeds" expected generated)
+ in
+ let experiment = Model.create_experiment () in
+ let missing_data_id () =
+ let experiment =
+ Experiment.
+ { experiment with
+ external_data_required = ExternalDataRequired.create true
+ }
+ in
+ let assignment =
+ Model.create_assignment ~no_show:false ~participated:true ()
+ in
+ let res = Assignment.validate experiment assignment in
+ let expected =
+ Error Pool_common.Message.[ FieldRequired Field.ExternalDataId ]
+ in
+ check_result expected res
+ in
+ let mutually_exclusive () =
+ let assignment =
+ Model.create_assignment ~no_show:true ~participated:true ()
+ in
+ let res = Assignment.validate experiment assignment in
+ let expected =
+ Error
+ Pool_common.Message.[ MutuallyExclusive Field.(NoShow, Participated) ]
+ in
+ check_result expected res
+ in
+ missing_data_id ();
+ mutually_exclusive ()
+;;
+
let set_attendance_missing_data_id () =
let open Assignment in
let experiment = Model.create_experiment () in
@@ -203,26 +226,18 @@ let set_attendance_missing_data_id () =
external_data_required = ExternalDataRequired.create true
}
in
- let assignment = Model.create_assignment () in
+ let assignment =
+ Model.create_assignment ~no_show:true ~participated:true ()
+ in
let session = Model.(create_session ~start:(an_hour_ago ()) ()) in
- let no_show = false |> NoShow.create in
- let participated = true |> Participated.create in
let events =
- AssignmentCommand.SetAttendance.handle
+ SessionCommand.Close.handle
experiment
session
[]
- [ ( assignment
- , no_show
- , participated
- , IncrementParticipationCount.create false
- , None
- , None )
- ]
- in
- let expected =
- Error Pool_common.Message.(FieldRequired Field.ExternalDataId)
+ [ assignment, IncrementParticipationCount.create false, None ]
in
+ let expected = Error Pool_common.Message.AssignmentsHaveErrors in
check_result expected events
;;
@@ -235,24 +250,21 @@ let set_attendance_with_data_id () =
external_data_required = ExternalDataRequired.create true
}
in
- let assignment = Model.create_assignment () in
+ let assignment =
+ Model.create_assignment
+ ~no_show:false
+ ~participated:false
+ ~external_data_id:"data-id"
+ ()
+ in
let session = Model.(create_session ~start:(an_hour_ago ()) ()) in
- let no_show = false |> NoShow.create in
- let participated = false |> Participated.create in
let increment_num_participaton = IncrementParticipationCount.create false in
- let external_data_id = Some (Assignment.ExternalDataId.of_string "data-id") in
let events =
- AssignmentCommand.SetAttendance.handle
+ SessionCommand.Close.handle
experiment
session
[]
- [ ( assignment
- , no_show
- , participated
- , increment_num_participaton
- , None
- , external_data_id )
- ]
+ [ assignment, increment_num_participaton, None ]
in
let expected =
let updated_contact =
@@ -264,9 +276,7 @@ let set_attendance_with_data_id () =
in
Ok
[ Session.Closed session |> Pool_event.session
- ; Assignment.AttendanceSet
- (assignment, no_show, participated, external_data_id)
- |> Pool_event.assignment
+ ; Assignment.Updated assignment |> Pool_event.assignment
; updated_contact
]
in
diff --git a/pool/test/command.ml b/pool/test/command.ml
index a55a4e563..6bb22d84a 100644
--- a/pool/test/command.ml
+++ b/pool/test/command.ml
@@ -133,6 +133,10 @@ let () =
"set invalid attendance on assignment"
`Quick
Assignment_test.set_invalid_attendance
+ ; test_case
+ "assignment validation"
+ `Quick
+ Assignment_test.assignment_validation
; test_case
"set attendance missing data id"
`Quick
@@ -336,10 +340,6 @@ let () =
"cancel with email and text notification"
`Quick
Session_test.cancel_with_email_and_text_notification
- ; test_case
- "close session before start"
- `Quick
- Session_test.close_before_start
; test_case "close session" `Quick Session_test.close_valid
; test_case
"close session with valid assignments"
diff --git a/pool/test/contact_counter_test.ml b/pool/test/contact_counter_test.ml
index a1306fc4d..aedc53199 100644
--- a/pool/test/contact_counter_test.ml
+++ b/pool/test/contact_counter_test.ml
@@ -13,7 +13,12 @@ let get_session session_id =
session_id |> Session.find database_label |> Lwt.map get_exn
;;
+let get_experiment experiment_id =
+ experiment_id |> Experiment.find database_label |> Lwt.map get_exn
+;;
+
let confirmation_mail (_ : Assignment.t) = Common_test.Data.create_email ()
+let invitation_mail (_ : Contact.t) = Ok (Common_test.Data.create_email ())
let find_assignment_by_contact_and_session contact_id session_id =
let open Assignment in
@@ -57,25 +62,29 @@ let close_session
experiment
=
let open Assignment in
- let open Assignment_command in
+ let open Session_command in
let%lwt assignment =
find_assignment_by_contact_and_session contact_id session.Session.id
in
- let no_show = no_show |> NoShow.create in
- let participated = participated |> Participated.create in
+ let assignment =
+ { assignment with
+ no_show = Some (NoShow.create no_show)
+ ; participated = Some (Participated.create participated)
+ }
+ in
let%lwt increment_num_participations =
contact_participation_in_other_assignments
database_label
- [ assignment ]
+ ~exclude_assignments:[ assignment ]
experiment.Experiment.id
contact_id
>|+ not
>|+ IncrementParticipationCount.create
||> get_exn
in
- (assignment, no_show, participated, increment_num_participations, None, None)
+ (assignment, increment_num_participations, None)
|> CCList.pure
- |> SetAttendance.handle experiment session []
+ |> Close.handle experiment session []
|> get_exn
|> Pool_event.handle_events database_label
;;
@@ -86,7 +95,7 @@ let delete_assignment experiment_id contact assignments =
Assignment.(
contact_participation_in_other_assignments
database_label
- assignments
+ ~exclude_assignments:assignments
experiment_id
(Contact.id contact)
>|+ not
@@ -115,6 +124,35 @@ let initialize contact_id experiment_id session_id ?followup_session_id () =
Lwt.return (contact, experiment, session, follow_up_session)
;;
+module InviteContact = struct
+ let contact_id = Contact.Id.create ()
+ let experiment_id = Experiment.Id.create ()
+ let session_id = Session.Id.create ()
+ let initialize = initialize contact_id experiment_id session_id
+
+ let invite _ () =
+ let%lwt contact, experiment, _, _ = initialize () in
+ let%lwt () =
+ Invitation_command.Create.(
+ handle
+ { experiment
+ ; contacts = [ contact ]
+ ; invited_contacts = []
+ ; create_message = invitation_mail
+ })
+ |> get_or_failwith_pool_error
+ |> Pool_event.handle_events database_label
+ in
+ let%lwt res = get_contact contact_id in
+ let expected = contact |> Contact.update_num_invitations ~step:1 in
+ let () =
+ Alcotest.(
+ check Test_utils.contact "num invitations increased" expected res)
+ in
+ Lwt.return ()
+ ;;
+end
+
module AttendAll = struct
let contact_id = Contact.Id.create ()
let session_id = Session.Id.create ()
@@ -463,3 +501,226 @@ module DeleteUnattended = struct
Lwt.return_unit
;;
end
+
+module UpdateClosedAssignments = struct
+ open Cqrs_command.Assignment_command
+ open CCResult
+ open Contact
+
+ let contact_id = Contact.Id.create ()
+ let session_id = Session.Id.create ()
+ let followup_session_id = Session.Id.create ()
+ let experiment_id = Experiment.Id.create ()
+ let initial_assignments = NumberOfAssignments.of_int 2
+ let initial_showups = NumberOfShowUps.of_int 1
+ let initial_noshows = NumberOfNoShows.of_int 1
+ let initial_participations = NumberOfParticipations.of_int 1
+
+ let initialize () =
+ initialize contact_id experiment_id session_id ~followup_session_id ()
+ >|> fun (contact, session, experiment, follow_ups) ->
+ let contact =
+ { contact with
+ num_assignments = initial_assignments
+ ; num_show_ups = initial_showups
+ ; num_no_shows = initial_noshows
+ ; num_participations = initial_participations
+ }
+ in
+ let%lwt () = Updated contact |> handle_event database_label in
+ Lwt.return (contact, session, experiment, follow_ups)
+ ;;
+
+ let get_entities () =
+ let%lwt contact = get_contact contact_id in
+ let%lwt session = get_session session_id in
+ let%lwt experiment = get_experiment experiment_id in
+ let%lwt followup_session = get_session followup_session_id in
+ Lwt.return (contact, experiment, session, followup_session)
+ ;;
+
+ let to_urlencoded ?external_data_id ~no_show ~participated () =
+ let open Pool_common in
+ let open Message in
+ let bool_to_string = Model.Boolean.stringify in
+ let base =
+ [ Field.(show NoShow), [ bool_to_string no_show ]
+ ; Field.(show Participated), [ bool_to_string participated ]
+ ]
+ in
+ match external_data_id with
+ | None -> base
+ | Some id -> base @ [ Field.(show ExternalDataId), [ id ] ]
+ ;;
+
+ let update_unclosed _ () =
+ let open UpdateClosed in
+ let%lwt contact, experiment, session, _ = initialize () in
+ let%lwt () = sign_up_for_session experiment contact session_id in
+ let%lwt assignment =
+ find_assignment_by_contact_and_session contact_id session_id
+ in
+ let participated_in_other_sessions = false in
+ let res =
+ to_urlencoded ~no_show:true ~participated:false ()
+ |> decode
+ >>= handle experiment session assignment participated_in_other_sessions
+ in
+ let expected = Error Pool_common.Message.SessionNotClosed in
+ let () =
+ check_result
+ ~msg:"Cannot update assignment of unclosed session"
+ expected
+ res
+ in
+ Lwt.return_unit
+ ;;
+
+ let close_main_session _ () =
+ let%lwt contact, experiment, session, _ = get_entities () in
+ let%lwt () =
+ close_session
+ ~no_show:false
+ ~participated:true
+ session
+ contact_id
+ experiment
+ in
+ let%lwt updated_contact = get_contact contact_id in
+ let expected =
+ contact
+ |> update_num_show_ups ~step:1
+ |> update_num_participations ~step:1
+ in
+ Alcotest.(
+ check
+ Test_utils.contact
+ "Session close: counters were updated"
+ expected
+ updated_contact)
+ |> Lwt.return
+ ;;
+
+ let update_assignment_manually _ () =
+ let%lwt contact, experiment, session, _ = get_entities () in
+ let participated_in_other_sessions assignments =
+ Assignment.(
+ contact_participation_in_other_assignments
+ database_label
+ ~exclude_assignments:assignments
+ experiment_id
+ contact_id
+ ||> get_or_failwith_pool_error)
+ in
+ let handle_update assignment urlencoded =
+ let%lwt participated_in_other_sessions =
+ participated_in_other_sessions [ assignment ]
+ in
+ let open UpdateClosed in
+ urlencoded
+ |> decode
+ >>= handle experiment session assignment participated_in_other_sessions
+ |> get_or_failwith_pool_error
+ |> Pool_event.handle_events database_label
+ in
+ let%lwt () =
+ let%lwt assignment =
+ find_assignment_by_contact_and_session contact_id session_id
+ in
+ let%lwt () =
+ to_urlencoded ~no_show:true ~participated:false ()
+ |> handle_update assignment
+ in
+ let expected =
+ assignment.Assignment.contact
+ |> update_num_show_ups ~step:(-1)
+ |> update_num_no_shows ~step:1
+ |> update_num_participations ~step:(-1)
+ in
+ let%lwt res = get_contact contact_id in
+ Alcotest.(
+ check Test_utils.contact "counters were manually updated" expected res)
+ |> Lwt.return
+ in
+ let%lwt () =
+ let%lwt assignment =
+ find_assignment_by_contact_and_session contact_id session_id
+ in
+ let%lwt () =
+ to_urlencoded ~no_show:false ~participated:true ()
+ |> handle_update assignment
+ in
+ let expected = contact in
+ let%lwt res = get_contact contact_id in
+ Alcotest.(
+ check Test_utils.contact "counters were manually updated" expected res)
+ |> Lwt.return
+ in
+ Lwt.return_unit
+ ;;
+
+ let close_followup_session _ () =
+ let%lwt contact, experiment, _, followup_session = get_entities () in
+ let%lwt () =
+ close_session
+ ~no_show:false
+ ~participated:true
+ followup_session
+ contact_id
+ experiment
+ in
+ let%lwt updated_contact = get_contact contact_id in
+ let expected = contact |> update_num_show_ups ~step:1 in
+ Alcotest.(
+ check
+ Test_utils.contact
+ "Follow up session closed: counters were updated"
+ expected
+ updated_contact)
+ |> Lwt.return
+ ;;
+
+ let update_follow_up_assignment_manually _ () =
+ let%lwt _, experiment, _, followup_session = get_entities () in
+ let participated_in_other_sessions assignments =
+ Assignment.(
+ contact_participation_in_other_assignments
+ database_label
+ ~exclude_assignments:assignments
+ experiment_id
+ contact_id
+ ||> get_or_failwith_pool_error)
+ in
+ let handle_update assignment urlencoded =
+ let%lwt participated_in_other_sessions =
+ participated_in_other_sessions [ assignment ]
+ in
+ let open UpdateClosed in
+ urlencoded
+ |> decode
+ >>= handle
+ experiment
+ followup_session
+ assignment
+ participated_in_other_sessions
+ |> get_or_failwith_pool_error
+ |> Pool_event.handle_events database_label
+ in
+ let%lwt assignment =
+ find_assignment_by_contact_and_session contact_id followup_session_id
+ in
+ let%lwt () =
+ to_urlencoded ~no_show:true ~participated:false ()
+ |> handle_update assignment
+ in
+ let expected =
+ assignment.Assignment.contact
+ |> update_num_show_ups ~step:(-1)
+ |> update_num_no_shows ~step:1
+ in
+ let%lwt res = get_contact contact_id in
+ Alcotest.(
+ check Test_utils.contact "counters were manually updated" expected res)
+ |> Lwt.return
+ ;;
+end
diff --git a/pool/test/filter_test.ml b/pool/test/filter_test.ml
index 4c61e8aed..1cf5c0aab 100644
--- a/pool/test/filter_test.ml
+++ b/pool/test/filter_test.ml
@@ -819,9 +819,13 @@ let filter_by_experiment_participation _ () =
Contact.equal assignment.contact contact)
||> get_exn_poolerror
in
- [ AttendanceSet
- (assignment, NoShow.create false, Participated.create true, None)
- |> Pool_event.assignment
+ let assignment =
+ { assignment with
+ no_show = Some (NoShow.create false)
+ ; participated = Some (Participated.create true)
+ }
+ in
+ [ Updated assignment |> Pool_event.assignment
; Session.Closed session |> Pool_event.session
]
|> run
diff --git a/pool/test/integration.ml b/pool/test/integration.ml
index 0869e6153..aafe24836 100644
--- a/pool/test/integration.ml
+++ b/pool/test/integration.ml
@@ -17,26 +17,29 @@ let suite =
`Slow
check_inactive_user_disable_after
; test_case
- "read inactive user warning after"
+ "read inactive user\n warning after"
`Slow
check_inactive_user_warning
- ; test_case "read languages" `Slow check_languages
+ ; test_case "read\n languages" `Slow check_languages
; test_case
"has terms and conditions"
`Slow
check_terms_and_conditions
; test_case
- "update terms and conditions"
+ "update terms and\n conditions"
`Slow
update_terms_and_conditions
- ; test_case "login after terms update" `Slow login_after_terms_update
+ ; test_case
+ "login after\n terms update"
+ `Slow
+ login_after_terms_update
] )
; ( "dev/test"
, [ test_case "intercept email" `Slow Common_test.validate_email ] )
; ( "authorization"
, Authorization_test.
[ test_case
- "permit valid operation"
+ "permit valid\n operation"
`Slow
recruiter_can_update_contact_language
; test_case
@@ -45,16 +48,22 @@ let suite =
guest_cannot_update_language
; test_case "use parametric roles" `Slow operator_works
; test_case
- "grant valid and invalid roles"
+ "grant valid\n and invalid roles"
`Slow
Admin_role_assignment.grant_roles
] )
; ( "partial_update"
, Partial_update.
- [ test_case "update with old version" `Slow update_with_old_version
- ; test_case "update custom field answer" `Slow update_custom_field
+ [ test_case
+ "update with old\n version"
+ `Slow
+ update_with_old_version
+ ; test_case
+ "update custom field\n answer"
+ `Slow
+ update_custom_field
; test_case
- "update custom field with invalid answer"
+ "update custom field with\n invalid answer"
`Slow
update_custom_field_with_invalid_answer
; test_case
@@ -62,7 +71,7 @@ let suite =
`Slow
update_admin_input_only_field_as_user
; test_case
- "update non override field as admin"
+ "update non override\n field as admin"
`Slow
update_non_override_field_as_admin
; test_case
@@ -70,7 +79,7 @@ let suite =
`Slow
set_value_of_none_required_field_to_null
; test_case
- "set value of required field to null"
+ "set value of\n required field to null"
`Slow
set_value_of_required_field_to_null
] )
@@ -83,7 +92,7 @@ let suite =
`Slow
validate_filter_with_unknown_field
; test_case
- "validate filter with invalid value"
+ "validate filter with\n invalid value"
`Slow
validate_filter_with_invalid_value
; test_case "filter contains all" `Slow filter_by_list_contains_all
@@ -94,7 +103,7 @@ let suite =
`Slow
retrieve_fitleterd_and_ordered_contacts
; test_case
- "create filter template with template"
+ "create filter\n template with template"
`Slow
create_filter_template_with_template
; test_case
@@ -106,11 +115,11 @@ let suite =
`Slow
no_admin_values_shown_to_contacts
; test_case
- "filter ignore admin value"
+ "filter ignore\n admin value"
`Slow
filter_ignore_admin_value
; test_case
- "filter by experiment participation"
+ "filter by\n experiment participation"
`Slow
filter_by_experiment_participation
; test_case
@@ -118,11 +127,11 @@ let suite =
`Slow
filter_by_empty_hardcoded_value
; test_case
- "filter by non-empty language"
+ "filter by non-empty\n language"
`Slow
filter_by_non_empty_hardcoded_value
; test_case
- "filter by empty custom field"
+ "filter\n by empty custom field"
`Slow
filter_by_empty_custom_field
; test_case
@@ -130,11 +139,11 @@ let suite =
`Slow
filter_by_non_empty_custom_field
; test_case
- "filter by empty custom field with deleted answer"
+ "filter by empty custom\n field with deleted answer"
`Slow
filter_by_empty_custom_field_with_deleted_value
; test_case
- "filter by date type custom field"
+ "filter by\n date type custom field"
`Slow
filter_by_date_custom_field
] )
@@ -155,7 +164,7 @@ let suite =
`Slow
get_template_with_language_missing
; test_case
- "get templates in multiple languages"
+ "get templates in\n multiple languages"
`Slow
get_templates_in_multile_languages
; test_case
@@ -163,7 +172,7 @@ let suite =
`Slow
experiment_invitation_with_sender
; test_case
- "assignment creation with sender"
+ "assignment creation with\n sender"
`Slow
assignment_creation_with_sender
] )
@@ -184,7 +193,7 @@ let suite =
; ( "waiting lists"
, Waiting_list_test.
[ test_case
- "find pending waiting lists entries by contcat"
+ "find pending waiting lists entries by\n contcat"
`Slow
PendingWaitingLists.find_pending_waitinglists_by_contact
; test_case
@@ -199,7 +208,7 @@ let suite =
; ( "experiment"
, Experiment_test.
[ test_case
- "list available experiments"
+ "list available\n experiments"
`Slow
AvailableExperiments.list_available_experiments
; test_case
@@ -212,18 +221,22 @@ let suite =
`Slow
AvailableExperiments.cancel_session
; test_case
- "mark assignments as deleted"
+ "mark assignments as\n deleted"
`Slow
AvailableExperiments.mark_assignment_as_deleted
] )
; ( "contact counter"
, Contact_counter_test.
[ test_case
- "attend all: register for session"
+ "invite contact: ssend invitation"
+ `Slow
+ InviteContact.invite
+ ; test_case
+ "attend all: register for\n session"
`Slow
AttendAll.register_for_session
; test_case
- "attend all: close first session"
+ "attend\n all: close first session"
`Slow
AttendAll.close_first_session
; test_case
@@ -231,7 +244,7 @@ let suite =
`Slow
AttendAll.close_follow_up_session
; test_case
- "delete attended: delete follow up"
+ "delete attended:\n delete follow up"
`Slow
DeleteAttended.delete_follow_up
; test_case
@@ -239,7 +252,7 @@ let suite =
`Slow
DeleteAttended.delete_main
; test_case
- "cancel session: without follow up"
+ "cancel session: without\n follow up"
`Slow
CancelSession.without_followups
; test_case "cancel session: follow up" `Slow CancelSession.follow_up
@@ -248,7 +261,7 @@ let suite =
`Slow
CancelSession.main_with_follow_up
; test_case
- "Do not attend: register for session"
+ "Do not attend:\n register for session"
`Slow
DoNotAttend.register_for_session
; test_case
@@ -256,18 +269,41 @@ let suite =
`Slow
DoNotAttend.close_main
; test_case
- "no show: register for session"
+ "no show: register for\n session"
`Slow
NoShow.register_for_session
- ; test_case "no show: close main" `Slow NoShow.close_main
; test_case
- "delete unattended: register"
+ "no show:\n close main"
+ `Slow
+ NoShow.close_main
+ ; test_case
+ "delete\n unattended: register"
`Slow
DeleteUnattended.register_for_session
; test_case
"delete unattended: delete main session assignment"
`Slow
DeleteUnattended.delete_main
+ ; test_case
+ "update closed: cannot delete of unclosed session"
+ `Slow
+ UpdateClosedAssignments.update_unclosed
+ ; test_case
+ "update closed: close main session"
+ `Slow
+ UpdateClosedAssignments.close_main_session
+ ; test_case
+ "update closed: update assignment manually"
+ `Slow
+ UpdateClosedAssignments.update_assignment_manually
+ ; test_case
+ "update closed: close follow up session"
+ `Slow
+ UpdateClosedAssignments.close_followup_session
+ ; test_case
+ "update closed: update follow up assignment manually"
+ `Slow
+ UpdateClosedAssignments.update_follow_up_assignment_manually
] )
; ( "tagging"
, Tag_test.
diff --git a/pool/test/session_test.ml b/pool/test/session_test.ml
index f0642336c..6ad679afc 100644
--- a/pool/test/session_test.ml
+++ b/pool/test/session_test.ml
@@ -880,22 +880,9 @@ let cancel_with_email_and_text_notification () =
res
;;
-let close_before_start () =
- let experiment = Test_utils.Model.create_experiment () in
- let session = Test_utils.Model.(create_session ~start:(in_an_hour ())) () in
- let res =
- Cqrs_command.Assignment_command.SetAttendance.handle
- experiment
- session
- []
- []
- in
- check_result (Error Pool_common.Message.SessionNotStarted) res
-;;
-
let close_valid () =
let experiment = Test_utils.Model.create_experiment () in
- let open Cqrs_command.Assignment_command.SetAttendance in
+ let open Cqrs_command.Session_command.Close in
let session = Test_utils.Model.(create_session ~start:(an_hour_ago ())) () in
let res = handle experiment session [] [] in
check_result (Ok [ Session.Closed session |> Pool_event.session ]) res
@@ -903,7 +890,7 @@ let close_valid () =
let close_valid_with_assignments () =
let experiment = Test_utils.Model.create_experiment () in
- let open Cqrs_command.Assignment_command in
+ let open Cqrs_command.Session_command in
let open Assignment in
let session = Test_utils.Model.(create_session ~start:(an_hour_ago ())) () in
let assignments =
@@ -912,25 +899,16 @@ let close_valid_with_assignments () =
()
|> Test_utils.Model.create_contact
|> create
+ ~no_show:(NoShow.create false)
+ ~participated:(Participated.create participated)
|> fun assignment ->
- ( assignment
- , NoShow.create false
- , Participated.create participated
- , Assignment.IncrementParticipationCount.create true
- , None
- , None ))
+ assignment, Assignment.IncrementParticipationCount.create true, None)
in
let tags = Tag_test.Data.Tag.create_with_description () |> CCList.return in
- let res = SetAttendance.handle experiment session tags assignments in
+ let res = Close.handle experiment session tags assignments in
let expected =
CCList.fold_left
- (fun events
- ( (assignment : Assignment.t)
- , no_show
- , participated
- , _
- , (_ : t list option)
- , (_ : ExternalDataId.t option) ) ->
+ (fun events ((assignment : Assignment.t), _, (_ : t list option)) ->
let contact_event =
let open Contact in
let contact =
@@ -938,7 +916,7 @@ let close_valid_with_assignments () =
|> update_num_show_ups ~step:1
|> update_num_participations ~step:1
in
- Updated contact |> Pool_event.contact
+ Contact.Updated contact |> Pool_event.contact
in
let tag_events =
let open Tags in
@@ -951,10 +929,7 @@ let close_valid_with_assignments () =
|> Pool_event.tags)
in
events
- @ [ AttendanceSet (assignment, no_show, participated, None)
- |> Pool_event.assignment
- ; contact_event
- ]
+ @ [ Updated assignment |> Pool_event.assignment; contact_event ]
@ tag_events)
[ Session.Closed session |> Pool_event.session ]
assignments
@@ -970,23 +945,16 @@ let close_with_deleted_assignment () =
let open Assignment in
let base = Test_utils.Model.create_assignment () in
let assignment =
- { base with marked_as_deleted = MarkedAsDeleted.create true }
+ { base with
+ marked_as_deleted = MarkedAsDeleted.create true
+ ; no_show = Some (NoShow.create false)
+ ; participated = Some (Participated.create true)
+ }
in
- let no_show = NoShow.create false in
- let participated = Participated.create true in
- ( assignment
- , no_show
- , participated
- , Assignment.IncrementParticipationCount.create false
- , None
- , None )
+ assignment, Assignment.IncrementParticipationCount.create false, None
in
let res =
- Cqrs_command.Assignment_command.SetAttendance.handle
- experiment
- session
- []
- [ command ]
+ Cqrs_command.Session_command.Close.handle experiment session [] [ command ]
in
check_result
(Error Pool_common.Message.(IsMarkedAsDeleted Field.Assignment))
@@ -994,41 +962,43 @@ let close_with_deleted_assignment () =
;;
let validate_invalid_participation () =
- let open Cqrs_command.Assignment_command.SetAttendance in
+ let open Cqrs_command.Session_command.Close in
let open Assignment in
let experiment = Test_utils.Model.create_experiment () in
let session = Test_utils.Model.(create_session ~start:(an_hour_ago ())) () in
+ let assignment =
+ Test_utils.Model.create_contact ()
+ |> create
+ ~no_show:(NoShow.create true)
+ ~participated:(Participated.create true)
+ in
let participation =
- ( Test_utils.Model.create_contact () |> create
- , NoShow.create true
- , Participated.create true
- , Assignment.IncrementParticipationCount.create false
- , None
- , None )
+ assignment, Assignment.IncrementParticipationCount.create false, None
in
let res = handle experiment session [] [ participation ] in
- let expected =
- Error Pool_common.Message.(MutuallyExclusive Field.(Participated, NoShow))
- in
+ let expected = Error Pool_common.Message.AssignmentsHaveErrors in
check_result expected res
;;
let close_unparticipated_with_followup () =
- let open Cqrs_command.Assignment_command.SetAttendance in
+ let open Cqrs_command.Session_command.Close in
let open Test_utils in
let open Assignment in
let experiment = Test_utils.Model.create_experiment () in
let session = Test_utils.Model.(create_session ~start:(an_hour_ago ())) () in
let contact = Model.create_contact () in
let assignment = Model.create_assignment ~contact () in
+ let assignment =
+ { assignment with
+ no_show = Some (NoShow.create false)
+ ; participated = Some (Participated.create false)
+ }
+ in
let follow_up = Model.create_assignment ~contact () in
let participation =
( assignment
- , NoShow.create false
- , Participated.create false
, Assignment.IncrementParticipationCount.create true
- , Some [ follow_up ]
- , None )
+ , Some [ follow_up ] )
in
let res = handle experiment session [] [ participation ] in
let expected =
@@ -1040,9 +1010,7 @@ let close_unparticipated_with_followup () =
in
Ok
[ Session.Closed session |> Pool_event.session
- ; Assignment.AttendanceSet
- (assignment, NoShow.create false, Participated.create false, None)
- |> Pool_event.assignment
+ ; Assignment.Updated assignment |> Pool_event.assignment
; Contact.Updated contact |> Pool_event.contact
; Assignment.MarkedAsDeleted follow_up |> Pool_event.assignment
]
@@ -1423,10 +1391,9 @@ let close_session_check_contact_figures _ () =
in
let%lwt () =
let open CCList in
+ let open Assignment in
contacts
|> map (fun (contact, status) ->
- let open Assignment in
- let open Contact in
let no_show, participated, increment_num_participatons =
match status with
| `Participated ->
@@ -1450,9 +1417,15 @@ let close_session_check_contact_figures _ () =
increment_num_participatons
|> Test_utils.get_or_failwith_pool_error
in
- [ AttendanceSet (find_assignment contact, no_show, participated, None)
- |> Pool_event.assignment
- ; Updated contact |> Pool_event.contact
+ let assignment = find_assignment contact in
+ let assignment =
+ { assignment with
+ no_show = Some no_show
+ ; participated = Some participated
+ }
+ in
+ [ Updated assignment |> Pool_event.assignment
+ ; Contact.Updated contact |> Pool_event.contact
])
|> flatten
|> cons (Session.Closed session |> Pool_event.session)
diff --git a/pool/test/test_utils.ml b/pool/test/test_utils.ml
index 6cde2ad5f..ebacfe53e 100644
--- a/pool/test/test_utils.ml
+++ b/pool/test/test_utils.ml
@@ -492,19 +492,29 @@ module Model = struct
Session.{ session with follow_up_to = Some main.id }
;;
- let create_assignment ?(contact = create_contact ()) () =
- Assignment.
- { id = Id.create ()
- ; contact
- ; no_show = None
- ; participated = None
- ; matches_filter = MatchesFilter.init
- ; canceled_at = None
- ; marked_as_deleted = MarkedAsDeleted.init
- ; external_data_id = None
- ; created_at = Pool_common.CreatedAt.create ()
- ; updated_at = Pool_common.UpdatedAt.create ()
- }
+ let create_assignment
+ ?no_show
+ ?participated
+ ?external_data_id
+ ?(contact = create_contact ())
+ ()
+ =
+ let open CCOption in
+ let open Assignment in
+ let no_show = no_show >|= NoShow.create in
+ let participated = participated >|= Participated.create in
+ let external_data_id = external_data_id >|= ExternalDataId.of_string in
+ { id = Id.create ()
+ ; contact
+ ; no_show
+ ; participated
+ ; matches_filter = MatchesFilter.init
+ ; canceled_at = None
+ ; marked_as_deleted = MarkedAsDeleted.init
+ ; external_data_id
+ ; created_at = Pool_common.CreatedAt.create ()
+ ; updated_at = Pool_common.UpdatedAt.create ()
+ }
;;
let create_message_template ?label ?language ?entity_uuid () =
diff --git a/pool/web/handler/admin_experiments_assignments.ml b/pool/web/handler/admin_experiments_assignments.ml
index b80d3071f..2f941e5c6 100644
--- a/pool/web/handler/admin_experiments_assignments.ml
+++ b/pool/web/handler/admin_experiments_assignments.ml
@@ -4,6 +4,9 @@ module Field = Pool_common.Message.Field
let src = Logs.Src.create "handler.admin.experiments_assignments"
let create_layout req = General.create_tenant_layout req
+let experiment_id = HttpUtils.find_id Experiment.Id.of_string Field.Experiment
+let session_id = HttpUtils.find_id Session.Id.of_string Field.Session
+let assignment_id = HttpUtils.find_id Assignment.Id.of_string Field.Assignment
let list ?(marked_as_deleted = false) req =
let open Utils.Lwt_result.Infix in
@@ -17,16 +20,17 @@ let list ?(marked_as_deleted = false) req =
let result ({ Pool_context.database_label; user; _ } as context) =
Utils.Lwt_result.map_error (fun err -> err, error_path)
@@
- let* actor = Pool_context.Utils.find_authorizable database_label user in
- let has_permission set =
- Guard.Persistence.validate database_label set actor ||> CCResult.is_ok
+ let%lwt access_contact_profiles =
+ Helpers.Guard.can_access_contact_profile database_label user
+ in
+ let%lwt view_contact_name =
+ Helpers.Guard.can_view_contact_name database_label user
in
- let%lwt view_contact_name = has_permission Contact.Guard.Access.read_name in
let%lwt view_contact_email =
- has_permission Contact.Guard.Access.read_email
+ Helpers.Guard.can_view_contact_email database_label user
in
let%lwt view_contact_cellphone =
- has_permission Contact.Guard.Access.read_cellphone
+ Helpers.Guard.can_view_contact_cellphone database_label user
in
let* experiment = Experiment.find database_label id in
let* sessions =
@@ -46,6 +50,7 @@ let list ?(marked_as_deleted = false) req =
sessions
||> CCList.all_ok
>|+ Page.Admin.Assignment.list
+ ~access_contact_profiles
~view_contact_name
~view_contact_email
~view_contact_cellphone
@@ -64,6 +69,7 @@ let list ?(marked_as_deleted = false) req =
(Ok [])
sessions
>|+ Page.Admin.Assignment.marked_as_deleted
+ ~access_contact_profiles
~view_contact_name
~view_contact_email
~view_contact_cellphone
@@ -78,15 +84,17 @@ let list ?(marked_as_deleted = false) req =
let index req = list req
let deleted req = list ~marked_as_deleted:true req
+let ids_from_request req =
+ let open Pool_common.Message.Field in
+ HttpUtils.(
+ ( find_id Experiment.Id.of_string Experiment req
+ , find_id Session.Id.of_string Session req
+ , find_id Assignment.Id.of_string Assignment req ))
+;;
+
let ids_and_redirect_from_req req =
let open Pool_common in
- let experiment_id, session_id, assignment_id =
- let open Message.Field in
- HttpUtils.(
- ( find_id Experiment.Id.of_string Experiment req
- , find_id Session.Id.of_string Session req
- , find_id Assignment.Id.of_string Assignment req ))
- in
+ let experiment_id, session_id, assignment_id = ids_from_request req in
let%lwt urlencoded = Sihl.Web.Request.to_urlencoded req in
let redirect =
let open Page.Admin.Assignment in
@@ -165,7 +173,7 @@ let mark_as_deleted req =
Assignment.(
contact_participation_in_other_assignments
database_label
- assignments
+ ~exclude_assignments:assignments
experiment_id
(Contact.id hd.contact)
>|+ not
@@ -191,6 +199,146 @@ let mark_as_deleted req =
result |> HttpUtils.extract_happy_path ~src req
;;
+let close_htmx req =
+ let tags = Pool_context.Logger.Tags.req req in
+ let experiment_id = experiment_id req in
+ let session_id = session_id req in
+ let assignment_id = assignment_id req in
+ let result ({ Pool_context.database_label; user; _ } as context) =
+ let open Cqrs_command.Assignment_command in
+ let open Utils.Lwt_result.Infix in
+ let boolean_fields = Assignment.boolean_fields |> CCList.map Field.show in
+ let%lwt urlencoded =
+ Sihl.Web.Request.to_urlencoded req
+ ||> HttpUtils.format_request_boolean_values boolean_fields
+ ||> HttpUtils.remove_empty_values
+ in
+ let%lwt view_contact_name =
+ Helpers.Guard.can_view_contact_name database_label user
+ in
+ let* experiment = Experiment.find database_label experiment_id in
+ let* session = Session.find database_label session_id in
+ let* assignment = Assignment.find database_label assignment_id in
+ let* assignment, event =
+ let open CCResult.Infix in
+ urlencoded
+ |> decode_update
+ >|= (fun { no_show; participated; external_data_id } ->
+ Assignment.
+ { assignment with
+ no_show = Some no_show
+ ; participated = Some participated
+ ; external_data_id
+ })
+ >>= (fun assignment ->
+ let events =
+ Assignment.(Updated assignment) |> Pool_event.assignment
+ in
+ Ok (assignment, events))
+ |> Lwt_result.lift
+ in
+ let%lwt () = Pool_event.handle_event ~tags database_label event in
+ let* counters = Assignment.counters_of_session database_label session_id in
+ Page.Admin.Session.close_assignment_htmx_row
+ ~counters
+ context
+ experiment
+ ~view_contact_name
+ session
+ assignment
+ |> HttpUtils.Htmx.html_to_plain_text_response
+ |> Lwt_result.return
+ in
+ result
+ |> HttpUtils.Htmx.handle_error_message ~error_as_notification:true ~src req
+;;
+
+let edit req =
+ let open Utils.Lwt_result.Infix in
+ let experiment_id, session_id, assignment_id = ids_from_request req in
+ let redirect_path =
+ Page.Admin.Session.session_path experiment_id session_id
+ in
+ let result ({ Pool_context.database_label; user; _ } as context) =
+ Utils.Lwt_result.map_error (fun err -> err, redirect_path)
+ @@
+ let%lwt view_contact_name =
+ Helpers.Guard.can_view_contact_name database_label user
+ in
+ let* experiment = Experiment.find database_label experiment_id in
+ let* session = Session.find database_label session_id in
+ let* assignment = Assignment.find database_label assignment_id in
+ Page.Admin.Assignment.edit
+ context
+ view_contact_name
+ experiment
+ session
+ assignment
+ >|> create_layout req context
+ >|+ Sihl.Web.Response.of_html
+ in
+ result |> HttpUtils.extract_happy_path ~src req
+;;
+
+let update req =
+ let open Utils.Lwt_result.Infix in
+ let open Assignment in
+ let experiment_id, session_id, assignment_id = ids_from_request req in
+ let redirect_path =
+ Page.Admin.Assignment.assignment_specific_path
+ ~suffix:"edit"
+ experiment_id
+ session_id
+ assignment_id
+ in
+ let result { Pool_context.database_label; _ } =
+ Utils.Lwt_result.map_error (fun err -> err, redirect_path)
+ @@
+ let tags = Pool_context.Logger.Tags.req req in
+ let boolean_fields = boolean_fields |> CCList.map Field.show in
+ let%lwt urlencoded =
+ Sihl.Web.Request.to_urlencoded req
+ ||> HttpUtils.format_request_boolean_values boolean_fields
+ ||> HttpUtils.remove_empty_values
+ in
+ let* assignment = find_closed database_label assignment_id in
+ let* experiment = Experiment.find database_label experiment_id in
+ let* session = Session.find database_label session_id in
+ let* participated_in_other_sessions =
+ Assignment.contact_participation_in_other_assignments
+ database_label
+ ~exclude_assignments:[ assignment ]
+ experiment_id
+ (Contact.id assignment.contact)
+ in
+ let events =
+ let open Cqrs_command.Assignment_command.UpdateClosed in
+ let open CCResult.Infix in
+ urlencoded
+ |> decode
+ >>= handle
+ ~tags
+ experiment
+ session
+ assignment
+ participated_in_other_sessions
+ |> 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
+ redirect_path
+ [ Message.set
+ ~success:[ Pool_common.Message.(Updated Field.Assignment) ]
+ ]
+ in
+ events |>> handle
+ in
+ result |> HttpUtils.extract_happy_path ~src req
+;;
+
module Access : sig
include module type of Helpers.Access
@@ -242,4 +390,10 @@ end = struct
|> combined_effects
|> Guardian.validate_generic
;;
+
+ let update =
+ Assignment.Guard.Access.update
+ |> combined_effects
+ |> Guardian.validate_generic
+ ;;
end
diff --git a/pool/web/handler/admin_session.ml b/pool/web/handler/admin_session.ml
index 205a52cdd..dcf9bb797 100644
--- a/pool/web/handler/admin_session.ml
+++ b/pool/web/handler/admin_session.ml
@@ -158,16 +158,14 @@ let detail req page =
let result ({ Pool_context.database_label; user; _ } as context) =
Utils.Lwt_result.map_error (fun err -> err, error_path)
@@
- let* actor = Pool_context.Utils.find_authorizable database_label user in
- let has_permission set =
- Guard.Persistence.validate database_label set actor ||> CCResult.is_ok
+ let%lwt view_contact_name =
+ Helpers.Guard.can_view_contact_name database_label user
in
- let%lwt view_contact_name = has_permission Contact.Guard.Access.read_name in
let%lwt view_contact_email =
- has_permission Contact.Guard.Access.read_email
+ Helpers.Guard.can_view_contact_email database_label user
in
let%lwt view_contact_cellphone =
- has_permission Contact.Guard.Access.read_cellphone
+ Helpers.Guard.can_view_contact_cellphone database_label user
in
let database_label = context.Pool_context.database_label in
let* session = Session.find database_label session_id in
@@ -182,7 +180,11 @@ let detail req page =
let* assignments =
Assignment.find_by_session database_label session.Session.id
in
+ let%lwt access_contact_profiles =
+ Helpers.Guard.can_access_contact_profile database_label user
+ in
Page.Admin.Session.detail
+ ~access_contact_profiles
~view_contact_name
~view_contact_email
~view_contact_cellphone
@@ -237,6 +239,9 @@ let detail req page =
database_label
(Experiment (Experiment.Id.to_common experiment_id)))
in
+ let* counters =
+ Assignment.counters_of_session database_label session_id
+ in
Page.Admin.Session.close
~view_contact_name
context
@@ -244,6 +249,7 @@ let detail req page =
session
assignments
participation_tags
+ counters
|> Lwt_result.ok
| `Reschedule ->
let* experiment = Experiment.find database_label experiment_id in
@@ -534,9 +540,7 @@ let close_post req =
let open Utils.Lwt_result.Infix in
Lwt_result.map_error (fun err -> err, Format.asprintf "%s/close" path)
@@
- let open Cqrs_command.Assignment_command in
- let open Assignment in
- let%lwt urlencoded = Sihl.Web.Request.to_urlencoded req in
+ let open Cqrs_command.Session_command in
let* experiment = Experiment.find database_label experiment_id in
let* session = Session.find database_label session_id in
let* assignments =
@@ -553,61 +557,34 @@ let close_post req =
[]
in
let* events =
- let urlencoded_list field =
- Sihl.Web.Request.urlencoded_list
- Pool_common.Message.Field.(array_key field)
- req
- in
- let find_external_data id =
- let open CCOption.Infix in
- let key =
- Format.asprintf "%s-%s" Field.(ExternalDataId |> show) (Id.value id)
- in
- CCList.assoc_opt ~eq:CCString.equal key urlencoded >>= CCList.head_opt
- in
- let%lwt no_shows = urlencoded_list Pool_common.Message.Field.NoShow in
- let%lwt participated =
- urlencoded_list Pool_common.Message.Field.Participated
- in
assignments
- |> Lwt_list.map_s (fun ({ Assignment.id; contact; _ } as assignment) ->
- let id = Id.value id in
- let find = CCList.mem ~eq:CCString.equal id in
- let no_show = no_shows |> find |> NoShow.create in
- let participated = participated |> find |> Participated.create in
- let* increment_num_participations =
- Assignment.contact_participation_in_other_assignments
- database_label
- [ assignment ]
- experiment_id
- (Contact.id contact)
- >|+ not %> IncrementParticipationCount.create
- in
- let%lwt follow_ups =
- match
- NoShow.value no_show || not (Participated.value participated)
- with
- | true ->
- find_follow_ups database_label assignment ||> CCOption.return
- | false -> Lwt.return_none
- in
- let* external_data_id =
- find_external_data assignment.id
- |> (function
- | None -> Ok None
- | Some value ->
- ExternalDataId.create value |> CCResult.map CCOption.return)
- |> Lwt_result.lift
- in
- Lwt_result.return
- ( assignment
- , no_show
- , participated
- , increment_num_participations
- , follow_ups
- , external_data_id ))
+ |> Lwt_list.map_s
+ (fun
+ ({ Assignment.no_show; participated; contact; _ } as assignment)
+ ->
+ let open Assignment in
+ let* increment_num_participations =
+ Assignment.contact_participation_in_other_assignments
+ database_label
+ ~exclude_assignments:[ assignment ]
+ experiment_id
+ (Contact.id contact)
+ >|+ not %> IncrementParticipationCount.create
+ in
+ let%lwt follow_ups =
+ let with_default fnc = CCOption.map_or ~default:false fnc in
+ match
+ with_default NoShow.value no_show
+ || not (with_default Participated.value participated)
+ with
+ | true ->
+ find_follow_ups database_label assignment ||> CCOption.return
+ | false -> Lwt.return_none
+ in
+ Lwt_result.return
+ (assignment, increment_num_participations, follow_ups))
||> CCResult.flatten_l
- >== SetAttendance.handle experiment session participation_tags
+ >== Close.handle experiment session participation_tags
in
let%lwt () = Pool_event.handle_events database_label events in
Http_utils.redirect_to_with_actions
@@ -857,7 +834,7 @@ end = struct
;;
let close =
- Cqrs_command.Assignment_command.SetAttendance.effects
+ SessionCommand.Close.effects
|> combined_effects
|> Guardian.validate_generic
;;
diff --git a/pool/web/handler/helpers_guard.ml b/pool/web/handler/helpers_guard.ml
index 2a2b9d564..13506a4dd 100644
--- a/pool/web/handler/helpers_guard.ml
+++ b/pool/web/handler/helpers_guard.ml
@@ -17,3 +17,19 @@ let find_roles_by_user database_label user =
let find_roles_of_ctx { Pool_context.database_label; user; _ } =
find_roles_by_user database_label user
;;
+
+let has_permission set database_label user =
+ let open Utils.Lwt_result.Infix in
+ Pool_context.Utils.find_authorizable database_label user
+ >>= Guard.Persistence.validate database_label set
+ ||> CCResult.is_ok
+;;
+
+let can_view_contact_name = has_permission Contact.Guard.Access.read_name
+let can_view_contact_email = has_permission Contact.Guard.Access.read_email
+
+let can_view_contact_cellphone =
+ has_permission Contact.Guard.Access.read_cellphone
+;;
+
+let can_access_contact_profile = has_permission Contact.Guard.Access.index
diff --git a/pool/web/view/component/component.ml b/pool/web/view/component/component.ml
index 93e55e212..ec177e40b 100644
--- a/pool/web/view/component/component.ml
+++ b/pool/web/view/component/component.ml
@@ -1,3 +1,4 @@
+module ButtonGroup = Component_button_group
module Calendar = Component_calendar
module Filter = Component_filter
module Icon = Component_icon
diff --git a/pool/web/view/component/component_assignment.ml b/pool/web/view/component/component_assignment.ml
deleted file mode 100644
index e69de29bb..000000000
diff --git a/pool/web/view/component/component_button_group.ml b/pool/web/view/component/component_button_group.ml
new file mode 100644
index 000000000..65b884739
--- /dev/null
+++ b/pool/web/view/component/component_button_group.ml
@@ -0,0 +1,11 @@
+open Tyxml.Html
+
+let dropdown buttons =
+ div
+ ~a:[ a_class [ "button-list" ] ]
+ [ div [ Component_icon.(to_html Sort) ]
+ ; ul
+ ~a:[ a_class [ "dropdown" ] ]
+ (buttons |> CCList.map CCFun.(CCList.return %> li))
+ ]
+;;
diff --git a/pool/web/view/component/component_input.ml b/pool/web/view/component/component_input.ml
index 2645abd9c..70a81d8b6 100644
--- a/pool/web/view/component/component_input.ml
+++ b/pool/web/view/component/component_input.ml
@@ -445,6 +445,7 @@ let textarea_element
let submit_element
lang
control
+ ?(is_text = false)
?(submit_type = `Primary)
?(classnames = [])
?has_icon
@@ -452,8 +453,9 @@ let submit_element
()
=
let button_type_class =
- submit_type_to_class submit_type
- :: CCOption.map_or ~default:[] (fun _ -> [ "has-icon" ]) has_icon
+ (submit_type_to_class submit_type
+ :: CCOption.map_or ~default:[] (fun _ -> [ "has-icon" ]) has_icon)
+ @ if is_text then [ "is-text" ] else []
in
let text_content =
span [ txt Pool_common.Utils.(control_to_string lang control) ]
@@ -480,6 +482,7 @@ let submit_icon ?(classnames = []) ?(attributes = []) icon_type =
;;
let link_as_button
+ ?(is_text = false)
?(style = `Primary)
?(classnames = [])
?(attributes = [])
@@ -488,7 +491,10 @@ let link_as_button
href
=
let classnames =
- let base = submit_type_to_class style :: "btn" :: classnames in
+ let base =
+ (submit_type_to_class style :: "btn" :: classnames)
+ @ if is_text then [ "is-text" ] else []
+ in
match icon with
| None -> base
| Some _ -> "has-icon" :: base
@@ -507,7 +513,9 @@ let link_as_button
| None -> txt ""
| Some (language, control) ->
let base =
- Pool_common.Utils.(control_to_string language control) |> txt
+ Pool_common.Utils.(control_to_string language control)
+ |> CCString.capitalize_ascii
+ |> txt
in
if CCOption.is_some icon then span [ base ] else base
in
diff --git a/pool/web/view/page/page_admin_assignments.ml b/pool/web/view/page/page_admin_assignments.ml
index 0dc161ead..dfbe84b87 100644
--- a/pool/web/view/page/page_admin_assignments.ml
+++ b/pool/web/view/page/page_admin_assignments.ml
@@ -9,14 +9,17 @@ let assignments_path experiment_id =
(experiment_id |> Experiment.Id.value)
;;
-let assignment_specific_path experiment_id session assignment =
+let assignment_specific_path ?suffix experiment_id session_id assignment_id =
let open Pool_common in
- Format.asprintf
- "/admin/experiments/%s/sessions/%s/%s/%s/%s"
- (experiment_id |> Experiment.Id.value)
- Session.(session.id |> Id.value)
- Message.Field.(human_url Assignments)
- Assignment.(assignment.id |> Id.value)
+ let base =
+ Format.asprintf
+ "/admin/experiments/%s/sessions/%s/%s/%s"
+ (experiment_id |> Experiment.Id.value)
+ Session.(session_id |> Id.value)
+ Message.Field.(human_url Assignments)
+ Assignment.(assignment_id |> Id.value)
+ in
+ suffix |> CCOption.map_or ~default:base (Format.asprintf "%s/%s" base)
;;
type assignment_redirect =
@@ -91,7 +94,14 @@ module Partials = struct
|> txt
;;
+ let identity view_contact_name contact id =
+ if view_contact_name
+ then Contact.lastname_firstname contact
+ else Id.value id
+ ;;
+
let overview_list
+ ?(access_contact_profiles = false)
?(view_contact_name = false)
?(view_contact_email = false)
?(view_contact_cellphone = false)
@@ -102,17 +112,26 @@ module Partials = struct
session
assignments
=
+ let open Pool_common in
let default = txt "" in
let deletable = CCFun.(Assignment.is_deletable %> CCResult.is_ok) in
let cancelable m =
Session.assignments_cancelable session |> CCResult.is_ok
&& Assignment.is_cancellable m |> CCResult.is_ok
in
- let action assignment suffix =
- assignment_specific_path experiment_id session assignment suffix
+ let editable = CCOption.is_some session.Session.closed_at in
+ let action { Assignment.id; _ } suffix =
+ assignment_specific_path ~suffix experiment_id session.Session.id id
|> Sihl.Web.externalize_path
in
- let button_form suffix confirmable control icon assignment =
+ let button_form
+ ?(style = `Primary)
+ suffix
+ confirmable
+ control
+ icon
+ assignment
+ =
let hidden_redirect_input =
input_element
~value:(show_assignment_redirect redirect)
@@ -130,12 +149,36 @@ module Partials = struct
]
[ csrf_element csrf ()
; hidden_redirect_input
- ; submit_element language control ~submit_type:`Error ~has_icon:icon ()
+ ; submit_element
+ ~is_text:true
+ ~submit_type:style
+ ~has_icon:icon
+ language
+ control
+ ()
]
in
+ let edit m =
+ let action = action m "edit" in
+ link_as_button
+ action
+ ~is_text:true
+ ~control:(language, Pool_common.Message.(Edit None))
+ ~icon:Component.Icon.Create
+ in
+ let profile_link { Assignment.contact; _ } =
+ let action =
+ Format.asprintf "/admin/contacts/%s" Contact.(id contact |> Id.value)
+ in
+ link_as_button
+ action
+ ~is_text:true
+ ~control:(language, Pool_common.Message.OpenProfile)
+ ~icon:Component.Icon.Person
+ in
let cancel =
- let open Pool_common in
button_form
+ ~style:`Error
"cancel"
I18n.(
if session.Session.has_follow_ups
@@ -145,8 +188,8 @@ module Partials = struct
Component.Icon.CloseCircle
in
let mark_as_deleted =
- let open Pool_common in
button_form
+ ~style:`Error
"mark-as-deleted"
I18n.(
if session.Session.has_follow_ups
@@ -179,11 +222,16 @@ module Partials = struct
[ Field.ExternalDataId, assignment_external_data_id ]
in
let thead =
- ((CCList.map fst contact_information
- @ CCList.map fst external_data_field
- @ Field.[ Participated; NoShow; CanceledAt ])
- |> Component.Table.fields_to_txt language)
- @ [ default ]
+ let field_to_text = Component.Table.field_to_txt language in
+ let left =
+ CCList.map (fun (field, _) -> field_to_text field) contact_information
+ @ CCList.map
+ (fun (field, _) -> field_to_text field)
+ external_data_field
+ in
+ let checkboxes = [ txt "P"; txt "NS" ] in
+ let right = [ Field.CanceledAt |> field_to_text; default ] in
+ left @ checkboxes @ right
in
let rows =
let open CCFun in
@@ -196,21 +244,34 @@ module Partials = struct
|> CCList.map (fun fcn -> fcn assignment)
in
let buttons =
- [ cancelable assignment, cancel
+ [ editable, edit
+ ; access_contact_profiles, profile_link
+ ; cancelable assignment, cancel
; deletable assignment, mark_as_deleted
]
|> CCList.filter_map (fun (active, form) ->
if not active then None else Some (form assignment))
- |> div ~a:[ a_class [ "flexrow"; "flex-gap"; "inline-flex" ] ]
+ |> Component.ButtonGroup.dropdown
|> CCList.pure
in
base @ buttons)
assignments
in
- Component.Table.horizontal_table `Striped ~align_last_end:true ~thead rows
+ div
+ [ p
+ [ Utils.hint_to_string language I18n.SessionCloseLegend
+ |> HttpUtils.add_line_breaks
+ ]
+ ; Component.Table.horizontal_table
+ `Striped
+ ~align_last_end:true
+ ~thead
+ rows
+ ]
;;
let grouped_overview_lists
+ ?access_contact_profiles
?view_contact_name
?view_contact_email
?view_contact_cellphone
@@ -238,6 +299,7 @@ module Partials = struct
~a:attrs
[ h3 ~a:[ a_class [ "heading-3" ] ] [ txt (session |> to_title) ]
; overview_list
+ ?access_contact_profiles
?view_contact_name
?view_contact_email
?view_contact_cellphone
@@ -255,6 +317,7 @@ module Partials = struct
end
let list
+ ?access_contact_profiles
?view_contact_name
?view_contact_email
?view_contact_cellphone
@@ -277,6 +340,7 @@ let list
]
]
; Partials.grouped_overview_lists
+ ?access_contact_profiles
?view_contact_name
?view_contact_email
?view_contact_cellphone
@@ -296,6 +360,7 @@ let list
;;
let marked_as_deleted
+ ?access_contact_profiles
?view_contact_name
?view_contact_email
?view_contact_cellphone
@@ -313,6 +378,7 @@ let marked_as_deleted
in
let list =
Partials.grouped_overview_lists
+ ?access_contact_profiles
?view_contact_name
?view_contact_email
?view_contact_cellphone
@@ -332,3 +398,79 @@ let marked_as_deleted
experiment
html)
;;
+
+let edit
+ ({ Pool_context.language; csrf; _ } as context)
+ view_contact_name
+ experiment
+ session
+ { Assignment.id; no_show; participated; external_data_id; contact; _ }
+ =
+ let open Assignment in
+ let open Component.Input in
+ let open CCOption.Infix in
+ let action =
+ assignment_specific_path experiment.Experiment.id session.Session.id id
+ in
+ let session_data =
+ let open Session in
+ let field_to_string = Pool_common.Utils.field_to_string language in
+ div
+ ~a:[ a_class [ "stack"; "inset"; "border"; " bg-grey-light" ] ]
+ [ p
+ [ txt (field_to_string Field.Start |> CCString.capitalize_ascii)
+ ; txt ": "
+ ; session.start
+ |> Start.value
+ |> Pool_common.Utils.Time.formatted_date_time
+ |> txt
+ ]
+ ; Component.Location.preview session.location
+ ]
+ in
+ [ div
+ ~a:[ a_class [ "switcher"; "flex-gap" ] ]
+ [ div
+ ~a:[ a_class [ "stack" ] ]
+ [ Component.Notification.notification
+ language
+ `Warning
+ [ txt
+ Pool_common.(
+ Utils.text_to_string language I18n.AssignmentEditTagsWarning)
+ ]
+ ; form
+ ~a:[ a_action action; a_method `Post ]
+ [ csrf_element csrf ()
+ ; div
+ ~a:[ a_class [ "flexcolumn"; "stack" ] ]
+ [ checkbox_element
+ ?value:(no_show >|= NoShow.value)
+ language
+ Field.NoShow
+ ; checkbox_element
+ ?value:(participated >|= Participated.value)
+ language
+ Field.Participated
+ ; input_element
+ ?value:(external_data_id >|= ExternalDataId.value)
+ language
+ `Text
+ Field.ExternalDataId
+ ; submit_element
+ language
+ ~classnames:[ "align-self-end" ]
+ Pool_common.Message.(Save None)
+ ()
+ ]
+ ]
+ ]
+ ; session_data
+ ]
+ ]
+ |> Layout.Experiment.(
+ create
+ context
+ (Text (Partials.identity view_contact_name contact id))
+ experiment)
+;;
diff --git a/pool/web/view/page/page_admin_session.ml b/pool/web/view/page/page_admin_session.ml
index 9cecef099..f88709c04 100644
--- a/pool/web/view/page/page_admin_session.ml
+++ b/pool/web/view/page/page_admin_session.ml
@@ -7,11 +7,13 @@ let session_title (s : Session.t) =
Pool_common.I18n.SessionDetailTitle (s.Session.start |> Session.Start.value)
;;
-let session_path experiment session =
+let session_counter_id = "session-counter-table"
+
+let session_path experiment_id session_id =
Format.asprintf
"/admin/experiments/%s/sessions/%s"
- Experiment.(Id.value experiment.id)
- Session.(session.id |> Id.value)
+ Experiment.(Id.value experiment_id)
+ Session.(session_id |> Id.value)
;;
let location_select language options selected () =
@@ -587,6 +589,7 @@ let new_form
;;
let detail
+ ?access_contact_profiles
?view_contact_name
?view_contact_email
?view_contact_cellphone
@@ -642,6 +645,27 @@ let detail
] ))
session.follow_up_to
in
+ let counters =
+ let length lst = lst |> CCList.length |> CCInt.to_string |> txt in
+ let open Assignment in
+ let assignment_count = Field.AssignmentCount, assignments |> length in
+ match session.Session.closed_at with
+ | None -> [ assignment_count ]
+ | Some (_ : Ptime.t) ->
+ assignment_count
+ :: [ ( Field.NoShowCount
+ , assignments
+ |> CCList.filter (fun { no_show; _ } ->
+ no_show |> CCOption.map_or ~default:false NoShow.value)
+ |> length )
+ ; ( Field.Participated
+ , assignments
+ |> CCList.filter (fun { participated; _ } ->
+ participated
+ |> CCOption.map_or ~default:false Participated.value)
+ |> length )
+ ]
+ in
let rows =
let amount amt = amt |> ParticipantAmount.value |> string_of_int in
[ ( Field.Start
@@ -677,7 +701,7 @@ let detail
|> CCOption.map (fun c ->
Field.ClosedAt, Utils.Time.formatted_date_time c |> txt)
in
- rows @ ([ canceled; closed ] |> CCList.filter_map CCFun.id)
+ rows @ ([ canceled; closed ] |> CCList.filter_map CCFun.id) @ counters
in
Table.vertical_table `Striped language ~align_top:true
@@ CCOption.map_or ~default:rows (CCList.cons' rows) parent
@@ -750,6 +774,7 @@ let detail
let assignment_list =
Page_admin_assignments.(
Partials.overview_list
+ ?access_contact_profiles
?view_contact_name
?view_contact_email
?view_contact_cellphone
@@ -803,7 +828,9 @@ let edit
=
let open Message_template in
let session_path =
- Format.asprintf "%s/%s" (session_path experiment session)
+ Format.asprintf
+ "%s/%s"
+ (session_path experiment.Experiment.id session.Session.id)
in
let form =
div
@@ -941,6 +968,130 @@ let follow_up
experiment)
;;
+let session_counters
+ language
+ { Assignment.total; num_no_shows; num_participations }
+ =
+ let field_to_string field =
+ Pool_common.Utils.field_to_string language field
+ |> CCString.capitalize_ascii
+ |> txt
+ in
+ div
+ ~a:
+ [ a_class [ "grid-col-2"; "gap" ]
+ ; a_id session_counter_id
+ ; a_user_data "hx-swap-oob" "true"
+ ]
+ [ div
+ ~a:[ a_class [ "flexcolumn" ] ]
+ ([ Field.Total, total
+ ; Field.NoShow, num_no_shows
+ ; Field.Participated, num_participations
+ ]
+ |> CCList.map (fun (field, value) ->
+ tr
+ [ td [ strong [ field_to_string field ] ]
+ ; td [ CCInt.to_string value |> txt ]
+ ])
+ |> table ~a:[ a_class [ "table"; "simple" ] ]
+ |> CCList.return)
+ ]
+;;
+
+let close_assignment_htmx_row
+ { Pool_context.language; csrf; _ }
+ (experiment : Experiment.t)
+ ~view_contact_name
+ session
+ ?counters
+ ({ Assignment.id; no_show; participated; external_data_id; contact; _ } as
+ assignment)
+ =
+ let open Assignment in
+ let open Pool_common.Utils in
+ let errors =
+ validate experiment assignment
+ |> function
+ | Ok () -> None
+ | Error err -> Some err
+ in
+ let session_path = session_path experiment.Experiment.id session.Session.id in
+ let checkbox_element field value =
+ let identifier = Format.asprintf "%s-%s" (Field.show field) (Id.value id) in
+ Input.checkbox_element ~value ~identifier language field
+ in
+ let default_bool fnc = CCOption.map_or ~default:false fnc in
+ let identity =
+ Page_admin_assignments.Partials.identity view_contact_name contact id
+ in
+ let action =
+ Format.asprintf "%s/assignments/%s/close" session_path (Id.value id)
+ |> Sihl.Web.externalize_path
+ in
+ let external_data_field =
+ let open Experiment in
+ match experiment.external_data_required |> ExternalDataRequired.value with
+ | false -> txt ""
+ | true ->
+ let value =
+ CCOption.map_or
+ ~default:""
+ Assignment.ExternalDataId.value
+ external_data_id
+ in
+ let field = Field.ExternalDataId in
+ div
+ ~a:[ a_class [ "form-group"; "flex-basis-30" ] ]
+ [ input
+ ~a:
+ [ a_input_type `Text
+ ; a_value value
+ ; a_name Field.(show field)
+ ; a_placeholder
+ (field_to_string language field |> CCString.capitalize_ascii)
+ ]
+ ()
+ ]
+ in
+ let errors =
+ errors
+ |> CCOption.map_or ~default:(txt "") (fun errors ->
+ let error_to_item err =
+ error_to_string language err |> txt |> CCList.return |> li
+ in
+ CCList.map error_to_item errors |> ul ~a:[ a_class [ "color-red" ] ])
+ in
+ form
+ ~a:
+ [ a_user_data "hx-post" action
+ ; a_user_data "hx-trigger" "change"
+ ; a_user_data "hx-swap" "outerHTML"
+ ; a_user_data "assignment" (Id.value id)
+ ; a_class [ "flexcolumn"; "stack-sm"; "inset-sm" ]
+ ]
+ [ div
+ ~a:[ a_class [ "flexrow"; "flex-gap-sm"; "flexcolumn-mobile" ] ]
+ [ csrf_element csrf ()
+ ; div
+ ~a:[ a_class [ "flex-basis-40"; "grow" ] ]
+ [ strong [ txt identity ] ]
+ ; div
+ ~a:[ a_class [ "flexcolumn"; "stack-xs"; "flex-basis-30" ] ]
+ [ checkbox_element
+ Message.Field.Participated
+ (default_bool Participated.value participated)
+ ; checkbox_element
+ Message.Field.NoShow
+ (default_bool NoShow.value no_show)
+ ]
+ ; external_data_field
+ ]
+ ; errors
+ ; counters |> CCOption.map_or ~default:(txt "") (session_counters language)
+ ]
+;;
+
let close
?(view_contact_name = false)
({ Pool_context.language; csrf; _ } as context)
@@ -948,199 +1099,108 @@ let close
(session : Session.t)
assignments
participation_tags
+ counters
=
let open Pool_common in
let control = Message.(Close (Some Field.Session)) in
- let form =
- let checkbox_element id field =
- div
- [ input
- ~a:
- [ a_input_type `Checkbox
- ; a_name Message.Field.(array_key field)
- ; a_value (id |> Assignment.Id.value)
+ let session_path = session_path experiment.Experiment.id session.Session.id in
+ let tags_html =
+ let participation_tags_list =
+ match participation_tags with
+ | [] ->
+ Utils.hint_to_string
+ language
+ I18n.SessionCloseNoParticipationTagsSelected
+ |> txt
+ | tags ->
+ let tags = Component.Tag.tag_list language tags in
+ div
+ [ p
+ [ Utils.hint_to_string
+ language
+ I18n.SessionCloseParticipationTagsSelected
+ |> txt
]
- ()
- ]
+ ; tags
+ ]
in
- let tags_html =
- let participation_tags_list =
- match participation_tags with
- | [] ->
- Utils.hint_to_string
- language
- I18n.SessionCloseNoParticipationTagsSelected
- |> txt
- | tags ->
- let tags = Component.Tag.tag_list language tags in
- div
- [ p
- [ Utils.hint_to_string
- language
- I18n.SessionCloseParticipationTagsSelected
- |> txt
- ]
- ; tags
- ]
- in
- div
- [ h4
- ~a:[ a_class [ "heading-4" ] ]
- [ txt (Utils.nav_link_to_string language I18n.Tags) ]
- ; participation_tags_list
+ div
+ [ h4
+ ~a:[ a_class [ "heading-4" ] ]
+ [ txt (Utils.nav_link_to_string language I18n.Tags) ]
+ ; participation_tags_list
+ ]
+ in
+ let table =
+ match assignments with
+ | [] ->
+ p
+ [ txt
+ Pool_common.(Utils.text_to_string language I18n.AssignmentListEmpty)
]
- in
- let table =
- let link (id, label) =
- span
- ~a:[ a_id id ]
- [ abbr
- ~a:
- [ a_title
- Pool_common.(
- Utils.control_to_string language Message.ToggleAll
- |> CCString.capitalize_ascii)
- ]
- [ txt label ]
- ]
- in
- let external_data_id_head, external_data_id_row =
- if Experiment.external_data_required_value experiment
- then
- ( [ Utils.field_to_string_capitalized
- language
- Message.Field.ExternalDataId
- |> txt
- ]
- , fun label data_id ->
- [ div
- ~a:[ a_class [ "form-group" ] ]
- [ input
- ~a:
- [ a_id label
- ; a_name label
- ; a_required ()
- ; a_input_type `Text
- ; a_value
- (CCOption.map_or
- ~default:""
- Assignment.ExternalDataId.value
- data_id)
- ]
- ()
- ]
- ] )
- else [], fun _ _ -> []
- in
- let thead =
- (txt "" :: external_data_id_head)
- @ ([ "all-no-show", "NS"; "all-participated", "P" ] |> CCList.map link)
- in
+ | assignments ->
CCList.map
- (fun ({ Assignment.id; contact; external_data_id; _ } : Assignment.t) ->
- let external_data_id_label =
- Format.asprintf
- "%s-%s"
- Message.Field.(ExternalDataId |> show)
- (Assignment.Id.value id)
- in
- let identity =
- if view_contact_name
- then Contact.fullname contact
- else Assignment.Id.value id
- in
- [ div [ strong [ txt identity ] ] ]
- @ external_data_id_row external_data_id_label external_data_id
- @ [ checkbox_element id Message.Field.NoShow
- ; checkbox_element id Message.Field.Participated
- ])
+ (close_assignment_htmx_row
+ context
+ experiment
+ ~view_contact_name
+ session)
assignments
- |> Table.horizontal_table ~thead `Striped
+ |> div ~a:[ a_class [ "flexcolumn"; "striped"; "gap" ] ]
|> fun table ->
- form
- ~a:
- [ a_method `Post
- ; a_class [ "stack" ]
- ; a_action
- (Format.asprintf
- "/admin/experiments/%s/sessions/%s/close"
- (Experiment.Id.value experiment.Experiment.id)
- Session.(Id.value session.id)
- |> Sihl.Web.externalize_path)
- ; a_user_data "detect-unsaved-changes" ""
- ]
- [ tags_html
- ; Input.csrf_element csrf ()
- ; table
- ; div
- ~a:[ a_class [ "flexrow"; "justify-end" ] ]
- [ Input.submit_element language control ~submit_type:`Primary () ]
- ]
- in
- let scripts =
- {js|
- const noShow = document.querySelectorAll('[name="no_show[]"]');
- for (let i = 0; i < noShow.length; i++) {
- let elm = noShow[i];
- let target = document.querySelector(`[name="participated[]"][value="${elm.value}"]`)
- elm.addEventListener("change", () => {
- if (elm.checked) {
- target.checked = false;
- }
- })
- }
-
- const participated = document.querySelectorAll('[name="participated[]"]');
- for (let i = 0; i < participated.length; i++) {
- let elm = participated[i];
- let target = document.querySelector(`[name="no_show[]"][value="${elm.value}"]`)
- elm.addEventListener("change", () => {
- if (elm.checked) {
- target.checked = false;
- }
- })
- }
-
- const isActive = (elm) => {
- return elm.dataset.active;
- }
+ let counters = session_counters language counters in
+ let scripts =
+ Format.asprintf
+ {js|
+ const noShow = "%s";
+ const participated = "%s";
- const setToggleState = (elm, state) => {
- if (state) {
- elm.dataset.active = true;
- } else {
- elm.removeAttribute("data-active");
- }
- }
+ const forms = document.querySelectorAll("form[data-assignment]");
- function toggleColumnValues(elements, value) {
- elements.forEach((elm) => {
- var event = new Event('change');
- elm.checked = value;
- elm.dispatchEvent(event);
+ document.addEventListener('htmx:beforeRequest', (e) => {
+ const form = e.detail.target;
+ const trigger = e.detail.requestConfig.triggeringEvent.srcElement;
+ switch (trigger.name) {
+ case noShow:
+ if(trigger.checked) {
+ e.detail.requestConfig.parameters['participated'] = false
+ }
+ break;
+ case participated:
+ if(trigger.checked) {
+ e.detail.requestConfig.parameters[noShow] = false
+ }
+ break;
+ default:
+ return;
+ }
});
- }
-
- const toggleNoShow = document.getElementById("all-no-show");
- const toggleParticipated = document.getElementById("all-participated");
-
- toggleNoShow.addEventListener("click", () => {
- const newState = !isActive(toggleNoShow);
- toggleColumnValues(noShow, newState);
- setToggleState(toggleNoShow, newState);
- setToggleState(toggleParticipated, !newState);
- })
-
- toggleParticipated.addEventListener("click", () => {
- const newState = !isActive(toggleParticipated);
- toggleColumnValues(participated, newState);
- setToggleState(toggleParticipated, newState);
- setToggleState(toggleNoShow, !newState);
- })
- |js}
- in
- div
- [ h4
+ |js}
+ Field.(show NoShow)
+ Field.(show Participated)
+ in
+ div [ table; counters; script (Unsafe.data scripts) ]
+ in
+ let submit_session_close =
+ form
+ ~a:
+ [ a_method `Post
+ ; a_class [ "stack" ]
+ ; a_action
+ (Format.asprintf "%s/close" session_path
+ |> Sihl.Web.externalize_path)
+ ; a_user_data "detect-unsaved-changes" ""
+ ]
+ [ Input.csrf_element csrf ()
+ ; div
+ ~a:[ a_class [ "flexrow"; "justify-end" ] ]
+ [ Input.submit_element language control ~submit_type:`Primary () ]
+ ]
+ in
+ [ div
+ [ p [ txt (session |> session_title |> Utils.text_to_string language) ]
+ ; tags_html
+ ; h4
~a:[ a_class [ "heading-4" ] ]
[ txt
(Utils.field_to_string language Message.Field.Participants
@@ -1154,14 +1214,9 @@ let close
[ Utils.hint_to_string language I18n.SessionCloseHints |> Unsafe.data
]
; table
- ; script (Unsafe.data scripts)
+ ; submit_session_close
]
- in
- div
- [ p [ txt (session |> session_title |> Utils.text_to_string language) ]
- ; form
- ]
- |> CCList.return
+ ]
|> Layout.Experiment.(create context (Control control) experiment)
;;
diff --git a/resources/index.scss b/resources/index.scss
index fefad5464..0cdf1cd05 100644
--- a/resources/index.scss
+++ b/resources/index.scss
@@ -108,10 +108,6 @@ $red-light: color.adjust($red, $lightness: $color-shades-ratio * 2);
}
// Flex
-.flex-basis-100 {
- flex-basis: 100%;
-}
-
.inline-flex {
display: inline-flex;
}
@@ -228,3 +224,103 @@ table.fixed {
[data-clipboard] {
cursor: copy;
}
+
+// Flex grid
+.flex-basis-100 {
+ flex-basis: 100%;
+}
+
+.flex-basis-40 {
+ flex-basis: 40%;
+}
+
+.flex-basis-30 {
+ flex-basis: 30%;
+}
+
+.flex-basis-20 {
+ flex-basis: 20%;
+}
+
+// Buttons
+.btn.is-text,
+button.is-text,
+input[type="submit"].is-text {
+ border: none;
+ background-color: transparent;
+
+ &.primary {
+ color: $color-primary;
+ }
+
+ &.error {
+ color: $red;
+ }
+
+ &.success {
+ color: $green;
+ }
+
+ &:hover {
+ background-color: transparent;
+ border: none;
+ }
+}
+
+
+.button-list {
+ position: relative;
+
+ i[class*='icon'] {
+ cursor: pointer;
+ }
+
+ &:hover .dropdown {
+ display: flex;
+ }
+
+ button,
+ .btn {
+ padding: $space-sm $space-md;
+ font-size: $body-font-size;
+ }
+
+ .dropdown {
+ @extend .flexcolumn;
+
+ // TODO: reuse mainnav dropdown
+ position: absolute;
+ display: none;
+ flex-direction: column;
+ border-radius: $dropdown-border-radius;
+ z-index: 1;
+ right: 0;
+ top: 0;
+ margin-top: 0;
+ transform: translateX(100%);
+ min-width: $dropdown-width;
+ white-space: pre;
+ background-color: $white;
+ color: $color-text-dark;
+ box-shadow: rgba(100, 100, 111, 0.2) 0px 7px 29px 0px;
+ transition-duration: $dropdown-transition-duration;
+
+ list-style-type: none;
+ padding-left: 0;
+ text-align: left;
+
+ & li {
+ margin-top: 0;
+ transition: $transition-duration;
+ display: flex;
+
+ &:hover {
+ background-color: $grey-light;
+ }
+
+ &>* {
+ width: 100%;
+ }
+ }
+ }
+}