Branch/20 merge contacts (#471)

* find duplicates draft

* include custom fields

* dry joins

* ignore null values

* ignore unverified and disabled contacts

* add index

* increase threshold

* basic UI

* add page title

* write results in db

* add detail page

* highlight equal values

* add ui to compare duplicates

* retrieve duplicates in both ways

* fix id select fragmen

* add weight for custom fields

* include in duplicate query

* implement weight in query and consider admin values

* refactor custom field pattern matches

* add hint

* add test case

* make combination unique and update type accordingly

* add contact unspecifiv view

* implement access

* migrate default permissions

* fix insert duplicates query

* add unique combination constraint

* merge duplicates

* replace multiple events with one transaction

* update all rows on merge

* changelog WIP

* changelog

* add user_users uuid index

* add integration test

* fix test cases

* remove unused function

* remove comments and unused functions

* create changelogs

* pass user_uuid to merge

* remove duplicates after mergin

* add service

* represent score as percentagre

* add migration to insert default weight

* add counters and verified timestamps to duplicate screen

* archive email address of deleted user

* add notification to dashboard

* resolve mr discussions

* get rid of exit 0 commands

* seed default weight

* fix list duplicates query

* adjust weighting and add hint

* fix ignore redirect

* add toggle all buttons

pool/app/archived_email/archived_email.ml

@@ -0,0 +1,3 @@
+include Entity
+
+let insert_request = Repo.insert_request

pool/app/archived_email/archived_email.mli

@@ -0,0 +1,5 @@
+module Reason : sig
+  type t = MergedDuplicate
+end
+
+val insert_request : (string * Reason.t, unit, [ `Zero ]) Caqti_request.t

pool/app/archived_email/dune

@@ -0,0 +1,17 @@
+(library
+ (name archived_email)
+ (libraries pool_common pool_user utils)
+ (preprocess
+  (pps
+   lwt_ppx
+   ppx_string
+   ppx_deriving.enum
+   ppx_deriving.eq
+   ppx_deriving.ord
+   ppx_deriving.show
+   ppx_fields_conv
+   ppx_sexp_conv
+   ppx_variants_conv
+   ppx_yojson_conv)))
+
+(include_subdirs unqualified)

pool/app/archived_email/entity.ml

@@ -0,0 +1,13 @@
+module Reason = struct
+  module Core = struct
+    let field = Pool_message.Field.MessageChannel
+
+    type t =
+      | MergedDuplicate [@name "merged_duplicate"]
+      [@printer Utils.ppx_printer "merged_duplicate"]
+    [@@deriving enum, eq, ord, sexp_of, show { with_path = false }, yojson]
+  end
+
+  include Pool_model.Base.SelectorType (Core)
+  include Core
+end

pool/app/archived_email/repo.ml

@@ -0,0 +1,30 @@
+open Caqti_request.Infix
+open CCFun.Infix
+
+module Email = struct
+  let t =
+    let open Utils.Crypto.String in
+    Pool_common.Repo.make_caqti_type
+      Caqti_type.string
+      (decrypt_from_string
+       %> CCResult.map_err (fun _ -> Pool_message.(Error.Decode Field.Email)))
+      encrypt_to_string
+  ;;
+end
+
+module Reason = Pool_common.Repo.Model.SelectorType (Entity.Reason)
+
+let insert_request =
+  {sql|
+    INSERT INTO pool_archived_email_addresses (
+      uuid,
+      email, 
+      reason
+    ) VALUES (
+      UNHEX(REPLACE(UUID(), '-', '')),
+      $1,
+      $2
+    )
+  |sql}
+  |> Caqti_type.(t2 Email.t Reason.t ->. unit)
+;;

pool/app/assignment/assignment.ml

@@ -28,9 +28,11 @@ let assignment_to_experiment_exists database_label experiment_id contact =
 ;;
 
 let find_by_contact_and_experiment = Repo.Sql.find_by_contact_and_experiment
+let find_by_contact = Repo.Sql.find_by_contact
 let find_not_deleted_by_session = Repo.find_not_deleted_by_session
 let find_all_by_session = Repo.find_all_by_session
 let find_multiple_by_session = Repo.Sql.find_multiple_by_session
+let find_by_contact_to_merge = Repo.Sql.find_by_contact_to_merge
 let query_by_session = Repo.query_by_session
 let find_uncanceled_by_session = Repo.find_uncanceled_by_session
 

pool/app/assignment/assignment.mli

@@ -162,6 +162,7 @@ val find_by_contact_and_experiment
   -> Contact.t
   -> (Session.t * t) list Lwt.t
 
+val find_by_contact : Database.Label.t -> Contact.Id.t -> t list Lwt.t
 val find_not_deleted_by_session : Database.Label.t -> Session.Id.t -> t list Lwt.t
 val find_all_by_session : Database.Label.t -> Session.Id.t -> t list Lwt.t
 
@@ -171,6 +172,12 @@ val find_multiple_by_session
   -> Id.t list
   -> t list Lwt.t
 
+val find_by_contact_to_merge
+  :  Database.Label.t
+  -> contact:Contact.t
+  -> merged_contact:Contact.t
+  -> t list Lwt.t
+
 val query_by_session
   :  ?query:Query.t
   -> Database.Label.t
@@ -256,6 +263,13 @@ val equal_event : event -> event -> bool
 val pp_event : Format.formatter -> event -> unit
 val show_event : event -> string
 
+val create_changelog
+  :  ?user_uuid:Pool_common.Id.t
+  -> Database.Label.t
+  -> t
+  -> t
+  -> unit Lwt.t
+
 module Guard : sig
   module Target : sig
     val to_authorizable

pool/app/assignment/event.ml

@@ -9,13 +9,15 @@ type event =
   | Updated of t * t
 [@@deriving eq, show, variants]
 
+let create_changelog ?user_uuid pool before after =
+  let open Version_history in
+  let before = to_record before in
+  let after = to_record after in
+  insert pool ?user_uuid ~entity_uuid:before.Record.id ~before ~after ()
+;;
+
 let handle_event ?user_uuid pool : event -> unit Lwt.t =
-  let create_changelog before after =
-    let open Version_history in
-    let before = to_record before in
-    let after = to_record after in
-    insert pool ?user_uuid ~entity_uuid:before.Record.id ~before ~after ()
-  in
+  let create_changelog = create_changelog ?user_uuid pool in
   function
   | Canceled assignment ->
     let canceleled =

pool/app/assignment/repo/repo.ml

@@ -421,6 +421,25 @@ module Sql = struct
     ||> CCOption.to_result Pool_message.(Error.NotFound Field.Session)
   ;;
 
+  let find_by_contact_to_merge_request =
+    let open Caqti_request.Infix in
+    {sql| 
+      WHERE contact_uuid = UNHEX(REPLACE($1, '-', ''))
+      AND NOT EXISTS (
+        SELECT 1
+        FROM pool_assignments AS merge
+        WHERE pool_assignments.session_uuid = merge.session_uuid
+          AND merge.contact_uuid = UNHEX(REPLACE($2, '-', '')))
+    |sql}
+    |> find_request_sql
+    |> Caqti_type.(t2 Contact.Repo.Id.t Contact.Repo.Id.t) ->* t
+  ;;
+
+  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)
+  ;;
+
   let insert_request =
     let open Caqti_request.Infix in
     {sql|

pool/app/contact/contact.ml

@@ -22,5 +22,7 @@ module Repo = struct
 
   let joins = Repo.joins
   let sql_select_columns = Repo.sql_select_columns
+  let make_sql_select_columns = Repo.make_sql_select_columns
   let find_request_sql = Repo.find_request_sql
+  let update_request = Repo.update_request
 end

pool/app/contact/contact.mli

@@ -8,48 +8,23 @@ module Id : sig
 end
 
 module NumberOfInvitations : sig
-  type t
-
-  val init : t
-  val of_int : int -> t
-  val equal : t -> t -> bool
-  val update : int -> t -> t
+  include Entity.CounterSig
 end
 
 module NumberOfAssignments : sig
-  type t
-
-  val init : t
-  val of_int : int -> t
-  val equal : t -> t -> bool
-  val update : int -> t -> t
+  include Entity.CounterSig
 end
 
 module NumberOfShowUps : sig
-  type t
-
-  val init : t
-  val of_int : int -> t
-  val equal : t -> t -> bool
-  val update : int -> t -> t
+  include Entity.CounterSig
 end
 
 module NumberOfNoShows : sig
-  type t
-
-  val init : t
-  val of_int : int -> t
-  val equal : t -> t -> bool
-  val update : int -> t -> t
+  include Entity.CounterSig
 end
 
 module NumberOfParticipations : sig
-  type t
-
-  val init : t
-  val of_int : int -> t
-  val equal : t -> t -> bool
-  val update : int -> t -> t
+  include Entity.CounterSig
 end
 
 module AdminComment : sig
@@ -95,13 +70,20 @@ val lastname_firstname : t -> string
 val email_address : t -> Pool_user.EmailAddress.t
 val cell_phone : t -> Pool_user.CellPhone.t option
 val is_inactive : t -> bool
+val num_participations : t -> NumberOfParticipations.t
+val num_invitations : t -> NumberOfInvitations.t
+val num_assignments : t -> NumberOfAssignments.t
+val num_show_ups : t -> NumberOfShowUps.t
+val num_no_shows : t -> NumberOfNoShows.t
 val sexp_of_t : t -> Sexplib0.Sexp.t
 val yojson_of_t : t -> Yojson.Safe.t
 val show : t -> string
 val compare : t -> t -> int
+val set_email_address : t -> Pool_user.EmailAddress.t -> t
 val set_firstname : t -> Pool_user.Firstname.t -> t
 val set_lastname : t -> Pool_user.Lastname.t -> t
 val set_language : t -> Pool_common.Language.t option -> t
+val set_cellphone : t -> Pool_user.CellPhone.t option -> t
 val find : Database.Label.t -> Id.t -> (t, Pool_message.Error.t) Lwt_result.t
 val find_admin_comment : Database.Label.t -> Id.t -> AdminComment.t option Lwt.t
 val find_multiple : Database.Label.t -> Id.t list -> t list Lwt.t
@@ -191,6 +173,12 @@ val update_num_show_ups : step:int -> t -> t
 val update_num_no_shows : step:int -> t -> t
 val update_num_participations : step:int -> t -> t
 
+module Write : sig
+  type t
+end
+
+val to_write : t -> Write.t
+
 module Preview : sig
   type t =
     { user : Pool_user.t
@@ -222,7 +210,9 @@ module Repo : sig
   val t : t Caqti_type.t
   val joins : string
   val sql_select_columns : string list
+  val make_sql_select_columns : user_table:string -> contact_table:string -> string list
   val find_request_sql : ?additional_joins:string list -> ?count:bool -> string -> string
+  val update_request : (Write.t, unit, [ `Zero ]) Caqti_request.t
 end
 
 module VersionHistory : Changelog.TSig with type record = t

pool/app/contact/entity.ml

@@ -4,6 +4,16 @@ open CCFun.Infix
 
 let model = Pool_message.Field.Contact
 
+module type CounterSig = sig
+  type t
+
+  val init : t
+  val of_int : int -> t
+  val equal : t -> t -> bool
+  val update : int -> t -> t
+  val value : t -> int
+end
+
 module Id = struct
   include Pool_model.Base.Id
 
@@ -91,6 +101,11 @@ let lastname m = m.user |> Pool_user.lastname
 let lastname_firstname m = m.user |> Pool_user.fullname ~reversed:true
 let email_address m = m.user.Pool_user.email
 
+let set_email_address m updated_email_address =
+  let user = Pool_user.{ m.user with email = updated_email_address } in
+  { m with user }
+;;
+
 let set_firstname m updated_firstname =
   let user = Pool_user.{ m.user with firstname = updated_firstname } in
   { m with user }
@@ -102,6 +117,7 @@ let set_lastname m updated_lastname =
 ;;
 
 let set_language m language = { m with language }
+let set_cellphone m cell_phone = { m with cell_phone }
 
 let create ?terms_accepted_at ?language user =
   { user

pool/app/contact/event.ml

@@ -114,6 +114,12 @@ let handle_event ?tags pool : event -> unit Lwt.t =
     contacts |> CCList.map id |> Repo.update_profile_updated_triggered pool
   | RegistrationAttemptNotificationSent t ->
     Repo.set_registration_attempt_notification_sent_at pool t
-  | Updated contact -> contact |> Repo.update pool
+  | Updated contact ->
+    let%lwt () = contact |> Repo.update pool in
+    let { Pool_user.email; lastname; firstname; _ } = user contact in
+    let%lwt (_ : Pool_user.t) =
+      Pool_user.update pool ~email ~lastname ~firstname contact.user
+    in
+    Lwt.return_unit
   | SignInCounterUpdated contact -> Repo.update_sign_in_count pool contact
 ;;

pool/app/contact/repo/repo.ml

@@ -4,30 +4,36 @@ module Dynparam = Database.Dynparam
 
 let src = Logs.Src.create "contact.repo"
 
+let make_sql_select_columns ~user_table ~contact_table =
+  let with_tablemame = Format.asprintf "%s.%s" contact_table in
+  Pool_user.Repo.make_sql_select_columns ~tablename:user_table
+  @ ([ "terms_accepted_at"
+     ; "language"
+     ; "experiment_type_preference"
+     ; "cell_phone"
+     ; "paused"
+     ; "disabled"
+     ; "verified"
+     ; "email_verified"
+     ; "num_invitations"
+     ; "num_assignments"
+     ; "num_show_ups"
+     ; "num_no_shows"
+     ; "num_participations"
+     ; "firstname_version"
+     ; "lastname_version"
+     ; "paused_version"
+     ; "language_version"
+     ; "experiment_type_preference_version"
+     ; "import_pending"
+     ; "created_at"
+     ; "updated_at"
+     ]
+     |> CCList.map with_tablemame)
+;;
+
 let sql_select_columns =
-  Pool_user.Repo.sql_select_columns
-  @ [ "pool_contacts.terms_accepted_at"
-    ; "pool_contacts.language"
-    ; "pool_contacts.experiment_type_preference"
-    ; "pool_contacts.cell_phone"
-    ; "pool_contacts.paused"
-    ; "pool_contacts.disabled"
-    ; "pool_contacts.verified"
-    ; "pool_contacts.email_verified"
-    ; "pool_contacts.num_invitations"
-    ; "pool_contacts.num_assignments"
-    ; "pool_contacts.num_show_ups"
-    ; "pool_contacts.num_no_shows"
-    ; "pool_contacts.num_participations"
-    ; "pool_contacts.firstname_version"
-    ; "pool_contacts.lastname_version"
-    ; "pool_contacts.paused_version"
-    ; "pool_contacts.language_version"
-    ; "pool_contacts.experiment_type_preference_version"
-    ; "pool_contacts.import_pending"
-    ; "pool_contacts.created_at"
-    ; "pool_contacts.updated_at"
-    ]
+  make_sql_select_columns ~user_table:"user_users" ~contact_table:"pool_contacts"
 ;;
 
 let joins =