Feature/159 user verification (#449)

* list status forms in table

* add verify handler for admins

* add hanlder to session close screen

* disable verification toggle if verified

* restructure session close page

* only allow to update verified until page is refreshed

* add test case

pool/app/contact/contact.mli

@@ -165,7 +165,6 @@ type session_participation =
 type event =
   | Created of create
   | EmailUpdated of t * Pool_user.EmailAddress.t
-  | Verified of t
   | EmailVerified of t
   | TermsAccepted of t
   | MarkedAsDeleted of t

pool/app/contact/event.ml

@@ -32,7 +32,6 @@ let set_password pool { user; _ } password password_confirmation =
 type event =
   | Created of create
   | EmailUpdated of t * Pool_user.EmailAddress.t
-  | Verified of t
   | EmailVerified of t
   | TermsAccepted of t
   | MarkedAsDeleted of t
@@ -84,10 +83,6 @@ let handle_event ?tags pool : event -> unit Lwt.t =
   | EmailUpdated (contact, email) ->
     let%lwt _ = Pool_user.update pool ~email contact.user in
     Lwt.return_unit
-  | Verified contact ->
-    Repo.update
-      pool
-      { contact with verified = Some (Pool_user.Verified.create_now ()) }
   | EmailVerified contact ->
     let%lwt (_ : Pool_user.t) = contact |> user |> Pool_user.confirm pool in
     Repo.update

pool/app/pool_common/entity_i18n.ml

@@ -297,6 +297,7 @@ type hint =
   | SessionCloseHints
   | SessionCloseLegendNoShow
   | SessionCloseLegendParticipated
+  | SessionCloseLegendVerified
   | SessionCloseNoParticipationTagsSelected
   | SessionCloseParticipationTagsSelected
   | SessionRegistrationFollowUpHint
@@ -320,6 +321,7 @@ type hint =
   | TextLengthMax of int
   | TextLengthMin of int
   | UserImportInterval
+  | VerifyContact
   | WaitingListPhoneMissingContact
 [@@deriving variants]
 

pool/app/pool_common/locales/i18n_de.ml

@@ -666,6 +666,7 @@ Wenn keine der Checkboxen angewählt ist, bedeutet das, dass der Kontakt erschie
     "Der Kontakt ist nicht an der Session erschienen"
   | SessionCloseLegendParticipated ->
     "Der Kontakt hat am Experiment teilgenommen"
+  | SessionCloseLegendVerified -> "Der Kontakt wurde verifiziert"
   | SessionCloseNoParticipationTagsSelected ->
     "Es wurden keine Tags ausgewählt, die den Teilnehmer/innen zugewiesen \
      werden, die an diesem Experiment teilgenommen haben."
@@ -735,6 +736,7 @@ Es können nur Sitzungen mit freien Plätzen ausgewählt werden.|}
   | UserImportInterval ->
     {|<p>Legen Sie fest, nach wie vielen Tagen eine Erinnerung an Kontakte gesendet werden soll, die den Import noch nicht bestätigt haben.</p>
 <p><strong>Die Einstellung "Zweite Erinnerung" legt fest, wie lange nach der ersten Erinnerung die zweite Erinnerung gesendet wird.</strong></p>|}
+  | VerifyContact -> "Den Kontakt als verifiziert markieren."
   | WaitingListPhoneMissingContact ->
     "Sie haben in Ihrem Profil noch keine Telefonnummer angegenen. Wir bitten \
      Sie, eine Telefonnummer anzugeben, damit das Rekrutierungsteam Sie \

pool/app/pool_common/locales/i18n_en.ml

@@ -642,6 +642,7 @@ If you trigger the reminders manually now, no more automatic reminders will be s
   | SessionCloseLegendNoShow -> "the contact did not show up"
   | SessionCloseLegendParticipated ->
     "the contact participated in the experiment"
+  | SessionCloseLegendVerified -> "the contact was verified"
   | SessionCloseNoParticipationTagsSelected ->
     "No tags were selected to be assigned to the participants who participated \
      in this experiment."
@@ -709,6 +710,7 @@ Only sessions with open spots can be selected.|}
   | UserImportInterval ->
     {|<p>Define after how many days a reminder will be sent to contacts that have not confirmed the import yet.</p>
 <p><strong>The 'second reminder' setting defines how long after the first reminder the second reminder is sent.</strong></p>|}
+  | VerifyContact -> "Mark the contact as verified."
   | WaitingListPhoneMissingContact ->
     "You have not entered a phone number in your profile yet. Please provide a \
      phone number so that the recruitment team can contact you."

pool/app/pool_common/locales/locales_de.ml

@@ -804,6 +804,7 @@ let control_to_string =
   | Stop field -> format_submit "stoppen" field
   | ToggleAll -> "alle umschalten"
   | Unassign field -> format_submit "entfernen" field
+  | Unverify -> "Als unverifiziert markieren"
   | Update field -> format_submit "aktualisieren" field
   | UpdateAssignmentsMatchFilter -> format_submit "Filter erneut ausführen" None
   | UpdateOrder -> "Reihenfolge anpassen"

pool/app/pool_common/locales/locales_en.ml

@@ -760,6 +760,7 @@ let control_to_string =
   | Stop field -> format_submit "stop" field
   | ToggleAll -> "toggle all"
   | Unassign field -> format_submit "unassign" field
+  | Unverify -> "Mark as unverified"
   | Update field -> format_submit "update" field
   | UpdateAssignmentsMatchFilter -> format_submit "rerun filter" None
   | UpdateOrder -> format_submit "update order" None

pool/app/pool_user/entity.ml

@@ -162,6 +162,7 @@ module Verified = struct
   include Pool_model.Base.Ptime
 
   let schema = schema Pool_message.Field.Verified CCResult.return
+  let equal a b = Sihl.Configuration.is_test () || equal a b
 end
 
 module EmailVerified = struct

pool/cqrs_command/contact_command.ml

@@ -442,3 +442,29 @@ end = struct
 
   let effects = Contact.Guard.Access.update
 end
+
+module ToggleVerified : sig
+  type t = Contact.t
+
+  val handle
+    :  ?tags:Logs.Tag.set
+    -> t
+    -> (Pool_event.t list, Pool_message.Error.t) result
+
+  val effects : Contact.Id.t -> Guard.ValidationSet.t
+end = struct
+  type t = Contact.t
+
+  let handle ?(tags = Logs.Tag.empty) contact =
+    Logs.info ~src (fun m -> m "Handle command ToggleVerified" ~tags);
+    let open Contact in
+    let verified =
+      match contact.verified with
+      | None -> Some (Pool_user.Verified.create_now ())
+      | Some _ -> None
+    in
+    Ok [ Contact.Updated { contact with verified } |> Pool_event.contact ]
+  ;;
+
+  let effects = Contact.Guard.Access.update
+end

pool/pool_message/pool_message_control.ml

@@ -64,6 +64,7 @@ type t =
   | Stop of Field.t option
   | ToggleAll
   | Unassign of Field.t option
+  | Unverify
   | Update of Field.t option
   | UpdateAssignmentsMatchFilter
   | UpdateOrder

pool/pool_message/pool_message_control.mli

@@ -61,6 +61,7 @@ type t =
   | Stop of Field.t option
   | ToggleAll
   | Unassign of Field.t option
+  | Unverify
   | Update of Field.t option
   | UpdateAssignmentsMatchFilter
   | UpdateOrder

pool/routes/routes.ml

@@ -415,6 +415,10 @@ module Admin = struct
             let specific =
               [ post "/cancel" ~middlewares:[ Access.cancel ] cancel
               ; post "/close" ~middlewares:[ Session.Access.close ] Close.update
+              ; post
+                  "/verify"
+                  ~middlewares:[ Session.Access.close ]
+                  Close.verify_contact
               ; get "/edit" ~middlewares:[ Access.update ] edit
               ; post "" ~middlewares:[ Access.update ] update
               ; post "/remind" ~middlewares:[ Access.update ] remind
@@ -664,6 +668,7 @@ module Admin = struct
         [ get "" ~middlewares:[ Access.read ] detail
         ; post "" ~middlewares:[ Access.update ] update
         ; post "pause" ~middlewares:[ Access.update ] toggle_paused
+        ; post "verify" ~middlewares:[ Access.update ] toggle_verified
         ; post "delete" ~middlewares:[ Access.update ] mark_as_deleted
         ; get "/edit" ~middlewares:[ Access.update ] edit
         ; post "/promote" ~middlewares:[ Access.promote ] promote

pool/test/command.ml

@@ -70,6 +70,7 @@ let () =
             Contact_test.request_email_validation_wrong_suffix
         ; test_case "update email" `Quick Contact_test.update_email
         ; test_case "verify email" `Quick Contact_test.verify_email
+        ; test_case "toggle verified" `Quick Contact_test.toggle_verified
         ; test_case
             "accept terms and condition"
             `Quick

pool/test/contact_test.ml

@@ -496,6 +496,25 @@ let verify_email () =
   check_result expected events
 ;;
 
+let toggle_verified () =
+  let open Contact in
+  let create_verified = Pool_user.Verified.create_now in
+  let contact = "[email protected]" |> contact_info |> create_contact true in
+  let run_test contact expected =
+    let open Cqrs_command.Contact_command.ToggleVerified in
+    let events = handle contact in
+    let expected = Ok [ expected |> Pool_event.contact ] in
+    check_result expected events
+  in
+  run_test
+    contact
+    (Updated { contact with verified = Some (create_verified ()) });
+  run_test
+    { contact with verified = Some (create_verified ()) }
+    (Updated { contact with verified = None });
+  ()
+;;
+
 let accept_terms_and_conditions () =
   let contact = "[email protected]" |> contact_info |> create_contact true in
   let events = Contact_command.AcceptTermsAndConditions.handle contact in

pool/test/filter_assignment_tests.ml

@@ -132,13 +132,6 @@ let contact ~prefix () =
     Pool_event.handle_events test_db verification_events |> Lwt_result.ok
   in
   let& contact = Contact.find test_db user_id in
-  let verification_events =
-    [ Contact.Verified contact |> Pool_event.contact ]
-  in
-  let& () =
-    Pool_event.handle_events test_db verification_events |> Lwt_result.ok
-  in
-  let& contact = Contact.find test_db user_id in
   Lwt_result.lift (Ok contact)
 ;;
 

pool/test/filter_invitation_tests.ml

@@ -85,13 +85,6 @@ let contact ~prefix () =
     Pool_event.handle_events test_db verification_events |> Lwt_result.ok
   in
   let& contact = Contact.find test_db invited_contact_id in
-  let verification_events =
-    [ Contact.Verified contact |> Pool_event.contact ]
-  in
-  let& () =
-    Pool_event.handle_events test_db verification_events |> Lwt_result.ok
-  in
-  let& contact = Contact.find test_db invited_contact_id in
   Lwt_result.lift (Ok contact)
 ;;
 

pool/test/integration_utils.ml

@@ -39,7 +39,7 @@ module ContactRepo = struct
       Model.create_contact ?id ?lastname ?language ~with_terms_accepted ()
     in
     let open Contact in
-    let confirm = [ Verified contact; EmailVerified contact ] in
+    let confirm = [ EmailVerified contact ] in
     let%lwt () =
       [ Created
           { user_id = id contact

pool/web/handler/admin_contacts.ml

@@ -319,6 +319,26 @@ let mark_as_deleted req =
   result |> HttpUtils.extract_happy_path ~src req
 ;;
 
+let toggle_verified req =
+  let open Utils.Lwt_result.Infix in
+  let id = contact_id req in
+  let redirect_path =
+    Format.asprintf "/admin/contacts/%s/edit" (Contact.Id.value id)
+  in
+  let tags = Pool_context.Logger.Tags.req req in
+  let result { Pool_context.database_label; _ } =
+    Lwt_result.map_error (fun err -> err, redirect_path)
+    @@
+    let* contact = Contact.find database_label id in
+    let events = Cqrs_command.Contact_command.ToggleVerified.handle contact in
+    events
+    |> Lwt_result.lift
+    |>> Pool_event.handle_events ~tags database_label
+    |>> fun () -> HttpUtils.redirect_to redirect_path
+  in
+  result |> HttpUtils.extract_happy_path ~src req
+;;
+
 let external_data_ids req =
   let open Utils.Lwt_result.Infix in
   let contact_id = contact_id req in

pool/web/handler/admin_experiments_assignments.ml

@@ -134,12 +134,23 @@ module Close = struct
     Lwt_result.return (experiment, session)
   ;;
 
-  let decode req =
-    let boolean_fields = Assignment.boolean_fields |> CCList.map Field.show in
-    req
-    |> Sihl.Web.Request.to_urlencoded
-    ||> HttpUtils.format_htmx_request_boolean_values boolean_fields
-    ||> UpdateHtmx.decode
+  let decode_update urlencoded =
+    let boolean_fields =
+      let open Field in
+      array_key Verified :: CCList.map show Assignment.boolean_fields
+    in
+    urlencoded
+    |> HttpUtils.format_htmx_request_boolean_values boolean_fields
+    |> UpdateHtmx.decode
+  ;;
+
+  let disabled_verified urlencoded =
+    let open CCOption in
+    CCList.assoc_opt ~eq:CCString.equal Field.(array_key Verified) urlencoded
+    >>= CCList.head_opt
+    >|= CCString.split_on_char ','
+    >|= CCList.map Assignment.Id.of_string
+    |> value ~default:[]
   ;;
 
   let updated_fields (a1 : t) (a2 : t) =
@@ -158,7 +169,12 @@ module Close = struct
     let result ({ Pool_context.database_label; language; _ } as context) =
       let* experiment, session = router_params req database_label in
       let* assignment = find database_label assignment_id in
-      let* updated = decode req >|+ UpdateHtmx.handle assignment in
+      let%lwt urlencoded = Sihl.Web.Request.to_urlencoded req in
+      let* updated =
+        decode_update urlencoded
+        |> Lwt_result.lift
+        >|+ UpdateHtmx.handle assignment
+      in
       let%lwt () =
         Pool_event.handle_event
           ~tags
@@ -169,8 +185,45 @@ module Close = struct
         counters_of_session database_label session.Session.id
       in
       let updated_fields = updated_fields assignment updated in
+      let disable_verified =
+        disabled_verified urlencoded |> CCList.mem assignment.id
+      in
+      Page.Admin.Session.
+        [ close_assignment_htmx_form
+            ~disable_verified
+            ~updated_fields
+            context
+            experiment
+            session
+            updated
+        ; session_counters language counters
+        ]
+      |> HttpUtils.Htmx.multi_html_to_plain_text_response
+      |> Lwt_result.return
+    in
+    result
+    |> HttpUtils.Htmx.handle_error_message ~error_as_notification:true ~src req
+  ;;
+
+  let verify_contact req =
+    let tags = Pool_context.Logger.Tags.req req in
+    let assignment_id = assignment_id req in
+    let result ({ Pool_context.database_label; language; _ } as context) =
+      let* experiment, session = router_params req database_label in
+      let* assignment = find database_label assignment_id in
+      let* events =
+        Cqrs_command.Contact_command.ToggleVerified.handle assignment.contact
+        |> Lwt_result.lift
+      in
+      let%lwt () = Pool_event.handle_events ~tags database_label events in
+      let updated_fields = [ Pool_message.Field.Verified ] in
+      let* updated = find database_label assignment_id in
+      let%lwt counters =
+        counters_of_session database_label session.Session.id
+      in
       Page.Admin.Session.
         [ close_assignment_htmx_form
+            ~disable_verified:false
             ~updated_fields
             context
             experiment
@@ -189,8 +242,10 @@ module Close = struct
     let tags = Pool_context.Logger.Tags.req req in
     let result ({ Pool_context.database_label; language; _ } as context) =
       let* experiment, session = router_params req database_label in
+      let%lwt urlencoded = Sihl.Web.Request.to_urlencoded req in
       let* decoded =
-        decode req
+        decode_update urlencoded
+        |> Lwt_result.lift
         >== fun decoded ->
         match decoded with
         | ExternalDataId _ -> Error Error.InvalidHtmxRequest
@@ -218,6 +273,7 @@ module Close = struct
         |> experiment_target_id
         |> Helpers.Guard.can_read_contact_name context
       in
+      let disabled_verified = disabled_verified urlencoded in
       Page.Admin.Session.
         [ close_assignments_table
             context
@@ -226,6 +282,7 @@ module Close = struct
             session
             assignments
             custom_fields
+            disabled_verified
         ; session_counters language counters
         ]
       |> HttpUtils.Htmx.multi_html_to_plain_text_response

pool/web/handler/helpers_contact_update.ml

@@ -8,6 +8,9 @@ let toggle_paused
   tags
   =
   let open Utils.Lwt_result.Infix in
+  let redirect_path =
+    Http_utils.url_with_field_params query_parameters redirect_path
+  in
   let open Pool_user in
   let paused = contact.Contact.paused |> Paused.value |> not |> Paused.create in
   let events =
@@ -26,6 +29,5 @@ let toggle_paused
   events
   |>> handle
   |>> redirect
-  |> Utils.Lwt_result.map_error (fun err ->
-    Http_utils.(err, url_with_field_params query_parameters redirect_path))
+  |> Utils.Lwt_result.map_error (fun err -> err, redirect_path)
 ;;