test: add first test for experiment filter

esy.json

@@ -10,15 +10,12 @@
     "@opam/containers": "3.12",
     "@opam/containers-data": "3.12",
     "@opam/cstruct": "*",
-    "@opam/dune": "*",
     "@opam/guardian": "*",
     "@opam/logs": "0.7.0",
     "@opam/lwt": "5.7.0",
     "@opam/lwt_ppx": "2.1.0",
     "@opam/lwt_ssl": "1.2.0",
     "@opam/mariadb": "*",
-    "@opam/ocaml-lsp-server": "*",
-    "@opam/ocamlformat": "0.26.1",
     "@opam/mirage-crypto": "*",
     "@opam/mirage-crypto-rng": "*",
     "@opam/mirage-crypto-rng-lwt": "*",
@@ -40,6 +37,11 @@
     "esy-openssl": "*",
     "ocaml": "4.14.0"
   },
+  "devDependencies": {
+    "@opam/dune": "*",
+    "@opam/ocamlformat": "*",
+    "@opam/ocaml-lsp-server": "*"
+  },
   "resolutions": {
     "@opam/caqti-lwt": "paurkedal/ocaml-caqti:caqti-lwt.opam#cba1047b9e318bc450be72ab9dfb302aac8e4a78",
     "@opam/canary": "uzh/canary#02cf40e029268560e160ca032850426e387aa598",

pool/app/experiment/entity.ml

@@ -143,6 +143,27 @@ let create
     }
 ;;
 
+let id t = t.id 
+let title t = t.title 
+let public_title t = t.public_title 
+let description t = t.description 
+let cost_center t = t.cost_center 
+let organisational_unit t = t.organisational_unit 
+let filter t = t.filter 
+let contact_person_id t = t.contact_person_id 
+let smtp_auth_id t = t.smtp_auth_id 
+let direct_registration_disabled t = t.direct_registration_disabled 
+let registration_disabled t = t.registration_disabled 
+let allow_uninvited_signup t = t.allow_uninvited_signup 
+let external_data_required t = t.external_data_required 
+let show_external_data_id_links t = t.show_external_data_id_links 
+let experiment_type t = t.experiment_type 
+let email_session_reminder_lead_time t = t.email_session_reminder_lead_time 
+let text_message_session_reminder_lead_time t = t.text_message_session_reminder_lead_time
+let invitation_reset_at t = t.invitation_reset_at 
+let created_at t = t.created_at 
+let updated_at t = t.updated_at 
+
 module DirectEnrollment = struct
   type t =
     { id : Id.t

pool/app/filter/entity.ml

@@ -40,6 +40,19 @@ type value =
   | Lst of single_val list [@printer print "list"] [@name "list"]
 [@@deriving show { with_path = false }, eq, variants]
 
+module Value = struct
+let string s = Str s
+let bool b = Bool b
+let date d = Date d
+let language l = Language l
+let number n = Nr n
+let option o = Option o
+
+let list xs = Lst xs
+let single v = Single v
+let no_value = NoValue
+end
+
 let single_value_of_yojson (yojson : Yojson.Safe.t) =
   let error = Pool_common.Message.(Invalid Field.Value) in
   let open CCResult in

pool/app/filter/filter.mli

@@ -17,6 +17,21 @@ type value =
   | Single of single_val
   | Lst of single_val list
 
+module Value : sig
+
+val string : string -> single_val
+val bool : bool -> single_val
+val date : Ptime.date -> single_val
+val language : Pool_common.Language.t -> single_val
+val number : float -> single_val
+val option : Custom_field.SelectOption.Id.t -> single_val
+
+val list : single_val list -> value
+val single : single_val -> value
+val no_value : value
+
+end
+
 module Key : sig
   type input_type =
     | Bool

pool/test/assignments_filter_test.ml

@@ -0,0 +1,52 @@
+(*
+
+test 1: 1 assigned contact, 1 probe contact
+test 2: 1 assigned contact marked as deleted, 1 contacts was found
+test 3: 1 assigned contact marked as cancelled, no contacts found
+
+*)
+
+(**
+subquery_for_invitation
+
+let sessions = [ session ] in
+let experiments = [
+  Experiment sessions
+] in
+
+let assigned_contact = 
+  { user_id : Id.t
+  ; email : User.EmailAddress.t
+  ; password : User.Password.t [@opaque]
+  ; firstname : User.Firstname.t
+  ; lastname : User.Lastname.t
+  ; terms_accepted_at : User.TermsAccepted.t option
+  ; language : Pool_common.Language.t option
+  }
+ in
+let invitation = Assignment.create invited_contact in
+
+let probe_contact = Contact.create contact in
+
+let events = [
+  Contact.created invited_contact;
+] in
+let _ = Pool_event.handle_events events in
+
+let invitation_filter = 
+  let open Filter in
+  let key = Key.(Hardcoded Assignment) in
+  let value = 
+    let exp_ids = experiment_ids |> CCList.map (fun id -> Str (id |> Experiment.Id.value)) in
+    (Lst exp_ids)
+    in
+  let predicate = (Predicate.create operator key value ) in
+  Pred predicate
+in
+
+let found_contacts = Filter.find_filtered_contacts
+  test_db base_filter (Some filter)
+
+assert [1 == probe_contact]
+assert []
+*)

pool/test/dune

@@ -1,5 +1,9 @@
 (tests
- (names command integration)
+ (names
+   command
+   integration
+   experiment_filter_test
+   )
  (libraries
   admin
   alcotest

pool/test/experiment_filter_test.ml

@@ -0,0 +1,190 @@
+(* test 1: 1 invited contact, 1 probe contact test 2: 1 invited contact, no
+   contacts left *)
+
+let ( let@ ) = Result.bind
+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
+
+(** 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.
+
+    It does so by:
+
+    1. creating a session
+    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
+
+    Fin. *)
+let test () =
+  (* 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 *)
+  let invitation_filter =
+    let open Filter in
+    let key : Key.t = Key.(Hardcoded Invitation) in
+    let value =
+      let exp_ids =
+        [ Experiment.(experiment.id) ]
+        |> List.map Experiment.Id.value
+        |> List.map Filter.Value.string
+      in
+      Lst exp_ids
+    in
+    let operator = Operator.(ListM.ContainsSome |> Operator.list) in
+    let predicate = Predicate.create key operator value in
+    Filter.create None (Pred predicate)
+  in
+  let& found_contacts =
+    Filter.find_filtered_contacts
+      test_db
+      Filter.MatchesFilter
+      (Some invitation_filter)
+  in
+  (* 7. assert on the found contacts *)
+  Alcotest.(
+    check
+      int
+      "wrong number of contacts returned"
+      2112
+      (List.length found_contacts));
+  Lwt_result.lift (Ok ())
+;;
+
+let () = Test_utils.run_test test