Skip to content

Commit

Permalink
clean test, make error message more helpful
Browse files Browse the repository at this point in the history
  • Loading branch information
@leostera
leostera committed Nov 23, 2023
1 parent 7d96531 commit 3a2791f
Show file tree
Hide file tree
Showing 3 changed files with 126 additions and 141 deletions.
4 changes: 3 additions & 1 deletion pool/app/pool_user/entity.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -151,7 +151,9 @@ module EmailAddress = struct
let open Mrmime in
match Mailbox.of_string email with
| Ok _ -> Ok email
| Error _ -> Error PoolError.(Invalid Field.EmailAddress)
| Error _ ->
Printf.printf "invalid_email: %s" email;
Error PoolError.(Invalid Field.EmailAddress)
;;

let strip_email_suffix email =
Expand Down
258 changes: 120 additions & 138 deletions pool/test/experiment_filter_test.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -3,6 +3,113 @@ let ( let* ) x f = Lwt_result.bind (Lwt_result.lift x) f
let ( let& ) = Lwt_result.bind
let test_db = Test_utils.Data.database_label

let session () =
let open Session in
let sid = Id.create () in
let now = Ptime_clock.now () in
let session_start = Start.create now in
let* session_duration =
Duration.create (Ptime.diff now (Ptime_clock.now ()))
in
let pid = Pool_location.Id.create () in
let pool_address = Pool_location.Address.virtual_ in
let pool_status = Pool_location.Status.Active in
let mapping_file = [] in
let* pool_location =
Pool_location.create
~id:pid
"a-pool-location"
None
pool_address
None
pool_status
mapping_file
in
let* max_participants = ParticipantAmount.create 2112 in
let* min_participants = ParticipantAmount.create 1984 in
let* overbook = ParticipantAmount.create 7 in
let session =
Session.create
~id:sid
session_start
session_duration
pool_location
max_participants
min_participants
overbook
in
Lwt_result.lift (Ok session)
;;

let experiment () =
let open Experiment in
let experiment_id = Id.create () in
let* title = Title.create "an-experiment-title" in
let* public_title = PublicTitle.create "a-public-title" in
let direct_registration_disabled = DirectRegistrationDisabled.create false in
let registration_disabled = RegistrationDisabled.create false in
let allow_uninvited_singup = AllowUninvitedSignup.create false in
let external_data_required = ExternalDataRequired.create false in
let show_external_data_id_links = ShowExternalDataIdLinks.create false in
let* experiment =
Experiment.create
~id:experiment_id
title
public_title
direct_registration_disabled
registration_disabled
allow_uninvited_singup
external_data_required
show_external_data_id_links
in
let experiment_created =
experiment |> Experiment.created |> Pool_event.experiment
in
let& () =
Pool_event.handle_event test_db experiment_created |> Lwt_result.ok
in
Experiment.find test_db experiment_id
;;

let contact () =
let open Contact in
let invited_contact_id = Id.create () in
let* email =
let email =
Format.asprintf "user+%s@domain.test" (Id.value invited_contact_id)
in
Pool_user.EmailAddress.create email
in
let* password = Pool_user.Password.create_unvalidated "a-password" in
let* firstname = Pool_user.Firstname.create "firstname" in
let* lastname = Pool_user.Lastname.create "lastname" in
let terms_accepted_at =
Pool_user.TermsAccepted.create (Ptime_clock.now ()) |> Option.some
in
let language = Pool_common.Language.En |> Option.some in
let contact_created =
Contact.created
{ user_id = invited_contact_id
; email
; password
; firstname
; lastname
; terms_accepted_at
; language
}
|> Pool_event.contact
in
let& () = Pool_event.handle_event test_db contact_created |> Lwt_result.ok in
Contact.find test_db invited_contact_id
;;

let invitation ~experiment ~contacts =
let invitation = Invitation.{ experiment; mailing = None; contacts } in
let event = Invitation.Created invitation |> Pool_event.invitation in
let& () = Pool_event.handle_event test_db event |> Lwt_result.ok in
Lwt_result.lift (Ok invitation)
;;

(** This test verifies that given a contact that was invited to an experiment,
and one that was not, the contact that was not invited will show after the
invitation exclusion filter is applied.
Expand All @@ -13,148 +120,23 @@ let test_db = Test_utils.Data.database_label
2. creating an experiment
3. creating a contact that is invited to the experiment
4. creating a contact that is NOT invited to the experiment
5. create all entities in the database
6. create a filter that for invitations that includes our experiment
7. assert on the found contacts
5. create a filter that for invitations that includes our experiment
6. assert on the found contacts
Fin. *)
let test =
Test_utils.case
@@ fun () ->
(* 1. create a session *)
let _session =
let open Session in
let sid = Id.create () in
let now = Ptime_clock.now () in
let session_start = Start.create now in
let* session_duration =
Duration.create (Ptime.diff now (Ptime_clock.now ()))
in
let pid = Pool_location.Id.create () in
let pool_address = Pool_location.Address.virtual_ in
let pool_status = Pool_location.Status.Active in
let mapping_file = [] in
let* pool_location =
Pool_location.create
~id:pid
"a-pool-location"
None
pool_address
None
pool_status
mapping_file
in
let* max_participants = ParticipantAmount.create 2112 in
let* min_participants = ParticipantAmount.create 1984 in
let* overbook = ParticipantAmount.create 7 in
let session =
Session.create
~id:sid
session_start
session_duration
pool_location
max_participants
min_participants
overbook
in
Lwt_result.lift (Ok session)
in
(* 2. create an experiment *)
let& experiment =
let open Experiment in
let experiment_id = Id.create () in
let* title = Title.create "an-experiment-title" in
let* public_title = PublicTitle.create "a-public-title" in
let direct_registration_disabled =
DirectRegistrationDisabled.create false
in
let registration_disabled = RegistrationDisabled.create false in
let allow_uninvited_singup = AllowUninvitedSignup.create false in
let external_data_required = ExternalDataRequired.create false in
let show_external_data_id_links = ShowExternalDataIdLinks.create false in
let* experiment =
Experiment.create
~id:experiment_id
title
public_title
direct_registration_disabled
registration_disabled
allow_uninvited_singup
external_data_required
show_external_data_id_links
in
let experiment_created =
experiment |> Experiment.created |> Pool_event.experiment
in
let& () =
Pool_event.handle_event test_db experiment_created |> Lwt_result.ok
in
Experiment.find test_db experiment_id
in
(* 3. create a contact that is invited to the experiment *)
let invited_contact_id = Contact.Id.create () in
let& invited_contact =
let open Contact in
let* email = Pool_user.EmailAddress.create "user@domain.test" in
let* password = Pool_user.Password.create_unvalidated "a-password" in
let* firstname = Pool_user.Firstname.create "firstname" in
let* lastname = Pool_user.Lastname.create "lastname" in
let terms_accepted_at =
Pool_user.TermsAccepted.create (Ptime_clock.now ()) |> Option.some
in
let language = Pool_common.Language.En |> Option.some in
let contact_created =
Contact.created
{ user_id = invited_contact_id
; email
; password
; firstname
; lastname
; terms_accepted_at
; language
}
|> Pool_event.contact
in
let& () =
Pool_event.handle_event test_db contact_created |> Lwt_result.ok
in
Contact.find test_db invited_contact_id
in
let invitation =
Invitation.{ experiment; mailing = None; contacts = [ invited_contact ] }
in
(* 4. create a contact that is NOT invited to the experiment *)
let probe_contact_id = Contact.Id.create () in
let& probe_contact =
let open Contact in
let* email = Pool_user.EmailAddress.create "probe@domain.test" in
let* password = Pool_user.Password.create_unvalidated "a-password" in
let* firstname = Pool_user.Firstname.create "probe-firstname" in
let* lastname = Pool_user.Lastname.create "probe-lastname" in
let terms_accepted_at =
Pool_user.TermsAccepted.create (Ptime_clock.now ()) |> Option.some
in
let language = Pool_common.Language.En |> Option.some in
let contact =
{ user_id = probe_contact_id
; email
; password
; firstname
; lastname
; terms_accepted_at
; language
}
in
Lwt_result.lift (Ok contact)
in
let events =
[ Contact.created probe_contact |> Pool_event.contact
; Invitation.Created invitation |> Pool_event.invitation
]
in
(* 5. create all entities in the database *)
let& () = Pool_event.handle_events test_db events |> Lwt_result.ok in
(* 6. create a filter that for invitations that includes our experiment *)
(* 1. creating a session *)
(* let _session = session () in *)
(* 2. creating an experiment *)
let& experiment = experiment () in
(* 3. creating a contact that is invited to the experiment *)
let& invited_contact = contact () in
let& _invitation = invitation ~experiment ~contacts:[ invited_contact ] in
(* 4. creating a contact that is NOT invited to the experiment *)
let& _probe_contact = contact () in
(* 5. create a filter that for invitations that includes our experiment *)
let invitation_filter =
let open Filter in
let key : Key.t = Key.(Hardcoded Invitation) in
Expand All @@ -176,7 +158,7 @@ let test =
Filter.MatchesFilter
(Some invitation_filter)
in
(* 7. assert on the found contacts *)
(* 6. assert on the found contacts *)
Alcotest.(
check
int
Expand Down
5 changes: 3 additions & 2 deletions pool/test/test_utils.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -552,6 +552,7 @@ end
value we have. It will fail a test if the underlying promise returns an
Error. *)
let case fn (_switch : Lwt_switch.t) () : unit Lwt.t =
let result = Lwt_result.get_exn @@ Lwt_result.catch fn in
Lwt.map (fun _ -> ()) result
match%lwt fn () with
| Ok () -> Lwt.return_unit
| Error err -> Pool_common.Message.error_to_exn err |> Lwt.fail
;;

0 comments on commit 3a2791f

Please sign in to comment.