Bug/merge contacts bugfixes (#481)

* fix merge queries and add test case

* add tag test

* undo formatting

pool/app/assignment/repo/repo.ml

@@ -265,7 +265,7 @@ module Sql = struct
           AND pool_assignments.canceled_at IS NULL
           AND pool_sessions.experiment_uuid = UNHEX(REPLACE(?, '-', ''))
     	  GROUP BY
-		      pool_assignments.contact_uuid    
+		      pool_assignments.contact_uuid
       |sql}
       (Contact.Repo.sql_select_columns |> CCString.concat ",")
       joins
@@ -437,7 +437,7 @@ module Sql = struct
 
   let find_by_contact_to_merge pool ~contact ~merged_contact =
     let open Contact in
-    Database.collect pool find_by_contact_to_merge_request (id contact, id merged_contact)
+    Database.collect pool find_by_contact_to_merge_request (id merged_contact, id contact)
   ;;
 
   let insert_request =

pool/app/duplicate_contacts/duplicate_contacts.ml

@@ -9,6 +9,15 @@ let find_by_contact = Repo.find_by_contact
 let count = Repo.count
 
 let merge pool ?user_uuid ({ contact; merged_contact; _ } as merge) =
+  let formatted contact =
+    let open Contact in
+    Format.asprintf
+      "%s(%s)"
+      (email_address contact |> Pool_user.EmailAddress.value)
+      (id contact |> Id.value)
+  in
+  Logs.info (fun m ->
+    m "Merging contact %s into %s" (formatted merged_contact) (formatted contact));
   let%lwt invitations =
     Invitation.find_by_contact_to_merge pool ~contact ~merged_contact
   in

pool/app/duplicate_contacts/duplicate_contacts.mli

@@ -17,6 +17,9 @@ type t =
   ; ignored : Ignored.t
   }
 
+val equal : t -> t -> bool
+val show : t -> string
+
 type merge =
   { contact : Contact.t
   ; merged_contact : Contact.t

pool/app/duplicate_contacts/repo_merge.ml

@@ -40,7 +40,7 @@ let uuid_sql dyn items to_id =
     CCList.foldi
       (fun (dyn, sql) i item ->
          ( dyn |> Dynparam.add Caqti_type.string (to_id item)
-         , sql @ [ Format.asprintf "$%d" (i + 2) ] ))
+         , sql @ [ Format.asprintf "UNHEX(REPLACE($%d, '-', ''))" (i + 2) ] ))
       (dyn, [])
       items
   in
@@ -149,6 +149,14 @@ let destroy_possible_duplicates =
   |> Contact.Repo.Id.t ->. unit
 ;;
 
+let destroy_user_import =
+  {sql|
+    DELETE FROM pool_user_imports
+    WHERE user_uuid = UNHEX(REPLACE($1, '-', ''))
+  |sql}
+  |> Contact.Repo.Id.t ->. unit
+;;
+
 let destroy_contact =
   {sql|
     DELETE FROM pool_contacts
@@ -317,6 +325,10 @@ let merge
     let (module Connection : Caqti_lwt.CONNECTION) = connection in
     Connection.exec destroy_possible_duplicates (id merged_contact)
   in
+  let destroy_user_import connection =
+    let (module Connection : Caqti_lwt.CONNECTION) = connection in
+    Connection.exec destroy_user_import (id merged_contact)
+  in
   let insert_archived_email connection =
     let (module Connection : Caqti_lwt.CONNECTION) = connection in
     let open Archived_email in
@@ -345,6 +357,7 @@ let merge
     ; destroy_assignments
     ; destroy_possible_duplicates
     ; insert_archived_email
+    ; destroy_user_import
     ; destroy_contact
     ; destroy_user
     ]

pool/app/invitation/repo/repo.ml

@@ -126,7 +126,7 @@ let find_by_contact_to_merge_request =
 
 let find_by_contact_to_merge pool ~contact ~merged_contact =
   let open Contact in
-  Database.collect pool find_by_contact_to_merge_request (id contact, id merged_contact)
+  Database.collect pool find_by_contact_to_merge_request (id merged_contact, id contact)
 ;;
 
 let find_binary_experiment_id_sql =

pool/app/waiting_list/repo/repo.ml

@@ -87,7 +87,7 @@ module Sql = struct
 
   let find_by_contact_to_merge pool ~contact ~merged_contact =
     let open Contact in
-    Database.collect pool find_by_contact_to_merge_request (id contact, id merged_contact)
+    Database.collect pool find_by_contact_to_merge_request (id merged_contact, id contact)
   ;;
 
   let find_by_experiment ?query pool id =

pool/test/command.ml

@@ -72,7 +72,7 @@ let () =
         ] )
     ; ( "duplicate_contacts"
       , Duplicate_contacts_test.
-          [ test_case "merge contacts" `Quick merge_contacts_command ] )
+          [ test_case "merge contacts" `Quick merge_contact_fields_command ] )
     ; ( "tenant"
       , [ test_case "create tenant smtp auth" `Quick Tenant_test.create_smtp_auth
         ; test_case

pool/test/duplicate_contacts_test.ml

@@ -46,7 +46,7 @@ let check_similarity _ () =
   Lwt.return ()
 ;;
 
-let merge_contacts_command () =
+let merge_contact_fields_command () =
   let open Command.Merge in
   let open Test_utils.Model in
   let open Duplicate_contacts in
@@ -186,18 +186,19 @@ module MergeData = struct
     | _, _ -> failwith "Custom field answer types do not match"
   ;;
 
+  let make_contact ~firstname ~lastname =
+    ContactRepo.create
+      ~firstname:(Pool_user.Firstname.of_string firstname)
+      ~lastname:(Pool_user.Lastname.of_string lastname)
+      ()
+  ;;
+
   let setup_merge_contacts () =
     let open Integration_utils in
     let open Pool_user in
     let pool = Test_utils.Data.database_label in
     let%lwt current_user = Integration_utils.create_contact_user () in
     let make_field name = CustomFieldRepo.create name (fun a -> Custom_field.Text a) in
-    let make_contact ~firstname ~lastname =
-      ContactRepo.create
-        ~firstname:(Firstname.of_string firstname)
-        ~lastname:(Lastname.of_string lastname)
-        ()
-    in
     let%lwt field_1 = make_field "F1" in
     let%lwt field_2 = make_field "F2" in
     let%lwt field_3 = make_field "F3" in
@@ -369,3 +370,94 @@ let override_b_with_a _ () =
   in
   Lwt.return_unit
 ;;
+
+let override_with_participations _ () =
+  let open Duplicate_contacts in
+  let open MergeData in
+  let%lwt current_user = Integration_utils.create_contact_user () in
+  let%lwt contact_a = make_contact ~firstname:"John11" ~lastname:"Doe11" in
+  let%lwt contact_b = make_contact ~firstname:"Jane22" ~lastname:"Doe22" in
+  let%lwt experiment = Integration_utils.ExperimentRepo.create () in
+  let%lwt session = Integration_utils.SessionRepo.create experiment () in
+  let%lwt tag = Integration_utils.TagRepo.create Tags.Model.Contact in
+  let assignment = Assignment.create contact_a in
+  (* Store participation of contact 1 *)
+  let%lwt () =
+    let open Assignment in
+    let handle = Pool_event.handle_events pool current_user in
+    let%lwt () =
+      [ Invitation.(Created { experiment; mailing = None; contacts = [ contact_a ] })
+        |> Pool_event.invitation
+      ; Contact.(
+          Updated { contact_a with num_invitations = NumberOfInvitations.of_int 1 }
+          |> Pool_event.contact)
+      ; Created (assignment, session.Session.id) |> Pool_event.assignment
+      ; Updated
+          ( assignment
+          , { assignment with
+              participated = Some (Participated.create true)
+            ; no_show = Some (NoShow.create false)
+            } )
+        |> Pool_event.assignment
+      ; Tags.(
+          Tagged
+            Tagged.
+              { tag_uuid = tag.id
+              ; model_uuid = Contact.(contact_a |> id |> Id.to_common)
+              })
+        |> Pool_event.tags
+      ]
+      |> handle
+    in
+    let%lwt assignment = find pool assignment.id ||> get_exn in
+    Cqrs_command.Session_command.Close.handle
+      experiment
+      session
+      []
+      [ assignment, IncrementParticipationCount.create true, None ]
+    |> get_exn
+    |> handle
+  in
+  (* Merge contacts: override b with a *)
+  let%lwt contact_a = Contact.find pool (Contact.id contact_a) ||> get_exn in
+  let duplicate =
+    Duplicate_contacts.
+      { id = Id.create ()
+      ; contact_a
+      ; contact_b
+      ; score = 1.0
+      ; ignored = Ignored.create false
+      }
+  in
+  let urlencoded =
+    make_urlencoded
+      ~email:contact_b
+      ~firstname:contact_b
+      ~lastname:contact_b
+      ~cell_phone:contact_b
+      ~language:contact_b
+      []
+  in
+  let%lwt () =
+    Command.Merge.handle urlencoded duplicate [] ([], [])
+    |> Lwt_result.lift
+    >>= merge pool
+    ||> get_exn
+  in
+  let open Contact in
+  let open Alcotest in
+  let%lwt result = find pool (id contact_b) ||> get_exn in
+  check int "no invites" 1 (num_invitations result |> NumberOfInvitations.value);
+  check int "no assignments" 1 (num_assignments result |> NumberOfAssignments.value);
+  check int "participations" 1 (num_participations result |> NumberOfParticipations.value);
+  check int "no shows" 0 (num_no_shows result |> NumberOfNoShows.value);
+  let%lwt is_enrolled =
+    Assignment.assignment_to_experiment_exists pool experiment.Experiment.id contact_b
+  in
+  check bool "contact_b is enrolled" true is_enrolled;
+  let%lwt tags =
+    Tags.(find_all_of_entity pool Model.Contact) Contact.(id contact_b |> Id.to_common)
+  in
+  check (list Test_utils.tag) "contact_b has tag" [ tag ] tags;
+  Lwt.return_unit
+;;

pool/test/integration.ml

@@ -368,6 +368,7 @@ let suite =
           [ test_case "check similarity" `Slow check_similarity
           ; test_case "override a with b" `Slow override_a_with_b
           ; test_case "override b with a" `Slow override_b_with_a
+          ; test_case "override with participations" `Slow override_with_participations
           ] )
     ; "cleanup", [ test_case "clean up test database" `Slow Test_seed.cleanup ]
     ]

pool/test/integration_utils.ml

@@ -214,6 +214,15 @@ module SessionRepo = struct
   ;;
 end
 
+module TagRepo = struct
+  let create ?(id = Tags.Id.create ()) ?(name = "Tag") model =
+    let open Tags in
+    let tag = Tags.create ~id (Title.of_string name) model |> get_or_failwith in
+    let%lwt () = Tags.(Created tag |> handle_event Data.database_label) in
+    Tags.find Data.database_label id |> Lwt.map get_or_failwith
+  ;;
+end
+
 module TimeWindowRepo = struct
   let create ?(current_user = default_current_user) ?id start duration experiment () =
     let time_window = Time_window.create ?id start duration experiment in

pool/test/test_utils.ml

@@ -21,6 +21,7 @@ let phone_nr = Pool_user.CellPhone.(Alcotest.testable pp equal)
 let pool_version = Pool_version.(Alcotest.testable pp equal)
 let smtp_auth = Email.SmtpAuth.(Alcotest.testable pp equal)
 let time_window_testable = Time_window.(Alcotest.testable pp equal)
+let tag = Tags.(Alcotest.testable pp equal)
 
 let check_result ?(msg = "succeeds") =
   let open Alcotest in

pool/web/view/page/page_admin_contact.ml

@@ -44,14 +44,6 @@ let personal_detail ?admin_comment ?custom_fields ?tags current_user language co
   let field_to_string =
     CCFun.(Pool_common.Utils.field_to_string language %> CCString.capitalize_ascii)
   in
-  let with_comment =
-    match admin_comment with
-    | None -> []
-    | Some comment ->
-      [ ( field_to_string Field.AdminComment
-        , comment |> AdminComment.value |> Http_utils.add_line_breaks )
-      ]
-  in
   let tags =
     tags
     |> CCOption.map_or ~default:[] (fun tags ->
@@ -75,28 +67,46 @@ let personal_detail ?admin_comment ?custom_fields ?tags current_user language co
       in
       ungrouped @ grouped)
   in
-  Pool_message.(
-    [ field_to_string Field.Name, fullname contact |> txt
-    ; ( field_to_string Field.Email
-      , email_address contact |> Pool_user.EmailAddress.value |> txt )
-    ; ( field_to_string Field.CellPhone
-      , contact.cell_phone |> CCOption.map_or ~default:"" Pool_user.CellPhone.value |> txt
-      )
-    ; ( field_to_string Field.Language
-      , contact.language |> CCOption.map_or ~default:"" Pool_common.Language.show |> txt )
-    ; ( field_to_string Field.TermsAndConditionsLastAccepted
-      , contact.terms_accepted_at
-        |> CCOption.map_or
-             ~default:""
-             (Pool_user.TermsAccepted.value %> Pool_model.Time.formatted_date_time)
-        |> txt )
+  let table_row (label, value) = tr [ th [ txt label ]; td [ value ] ] in
+  let counter_rows =
+    [ Field.InvitationCount, num_invitations %> NumberOfInvitations.value
+    ; Field.AssignmentCount, num_assignments %> NumberOfAssignments.value
+    ; Field.NoShowCount, num_no_shows %> NumberOfNoShows.value
+    ; Field.ShowUpCount, num_show_ups %> NumberOfShowUps.value
+    ; Field.Participated, num_participations %> NumberOfParticipations.value
     ]
-    @ with_comment
-    @ tags)
-  |> fun rows ->
+    |> CCList.map (fun (field, value) ->
+      field_to_string field, value contact |> string_of_int |> txt)
+  in
+  let info_rows =
+    Pool_message.
+      [ Field.Name, fullname contact |> txt
+      ; Field.Email, email_address contact |> Pool_user.EmailAddress.value |> txt
+      ; ( Field.CellPhone
+        , contact.cell_phone
+          |> CCOption.map_or ~default:"" Pool_user.CellPhone.value
+          |> txt )
+      ; ( Field.Language
+        , contact.language |> CCOption.map_or ~default:"" Pool_common.Language.show |> txt
+        )
+      ; ( Field.TermsAndConditionsLastAccepted
+        , contact.terms_accepted_at
+          |> CCOption.map_or
+               ~default:""
+               (Pool_user.TermsAccepted.value %> Pool_model.Time.formatted_date_time)
+          |> txt )
+      ; ( Field.AdminComment
+        , admin_comment
+          |> CCOption.map_or
+               ~default:(txt "")
+               (AdminComment.value %> Http_utils.add_line_breaks) )
+      ]
+    |> CCList.map (fun (field, value) -> field_to_string field, value)
+  in
   let rows =
-    CCList.map (fun (label, value) -> tr [ th [ txt label ]; td [ value ] ]) rows
+    (info_rows @ tags |> CCList.map table_row)
     @ custom_field_rows
+    @ (counter_rows |> CCList.map table_row)
   in
   table ~a:[ a_class (Table.table_classes `Striped ~align_top:true ()) ] rows
   |> fun html ->