2411: add resend login confirmation token functionality

pool/app/authentication/authentication.ml

@@ -5,10 +5,16 @@ let label = "reset OTP (authentication codes)"
 let src = Logs.Src.create "authentication.service"
 
 let create ?(id = Id.create ()) ?(token = Token.generate ()) ~user ~channel () =
-  { id; user_uuid = Pool_user.id user; channel; token }
+  { id
+  ; user_uuid = Pool_user.id user
+  ; channel
+  ; token
+  ; failed_attempts = FailedAttempts.of_int 0
+  }
 ;;
 
 let find_valid_by_id = Repo.find_valid_by_id
+let find_id_by_user = Repo.find_id_by_user
 
 let start () =
   let open Schedule in

pool/app/authentication/authentication.mli

@@ -21,13 +21,26 @@ module Token : sig
   val schema : unit -> (Pool_conformist.error_msg, t) Pool_conformist.Field.t
 end
 
+module FailedAttempts : sig
+  type t
+
+  val equal : t -> t -> bool
+  val pp : Format.formatter -> t -> unit
+  val show : t -> string
+  val value : t -> int
+  val of_int : int -> t
+  val limit : t
+end
+
 type t =
   { id : Id.t
   ; user_uuid : Pool_user.Id.t
   ; channel : Channel.t
   ; token : Token.t
+  ; failed_attempts : FailedAttempts.t
   }
 
+val resend_cooldown_seconds : int
 val equal : t -> t -> bool
 val show : t -> string
 val pp : Format.formatter -> t -> unit
@@ -42,7 +55,8 @@ val create
 
 type event =
   | Created of t
-  | Deleted of t
+  | Deleted of Id.t
+  | IncreaseFailedAttempts of t
   | ResetExpired
 
 val equal_event : event -> event -> bool
@@ -55,5 +69,6 @@ val find_valid_by_id
   -> Id.t
   -> (t * Pool_user.t, Pool_message.Error.t) Lwt_result.t
 
+val find_id_by_user : Database.Label.t -> Pool_user.Id.t -> Id.t option Lwt.t
 val lifecycle : Sihl.Container.lifecycle
 val register : unit -> Sihl.Container.Service.t

pool/app/authentication/entity.ml

@@ -18,6 +18,12 @@ module Channel = struct
   include Core
 end
 
+module FailedAttempts = struct
+  include Pool_model.Base.Integer
+
+  let limit = of_int 3
+end
+
 module Token = struct
   include Pool_model.Base.String
 
@@ -47,5 +53,8 @@ type t =
   ; user_uuid : Pool_user.Id.t
   ; channel : Channel.t
   ; token : Token.t
+  ; failed_attempts : FailedAttempts.t
   }
 [@@deriving eq, show { with_path = false }]
+
+let resend_cooldown_seconds = 60

pool/app/authentication/event.ml

@@ -2,12 +2,14 @@ open Entity
 
 type event =
   | Created of t
-  | Deleted of t
+  | Deleted of Id.t
+  | IncreaseFailedAttempts of t
   | ResetExpired
 [@@deriving eq, show]
 
 let handle_event pool = function
   | Created t -> Repo.insert pool t
   | Deleted t -> Repo.delete pool t
+  | IncreaseFailedAttempts t -> Repo.increase_failed_attempts pool t
   | ResetExpired -> Repo.reset_expired pool ()
 ;;

pool/app/authentication/repo.ml

@@ -7,14 +7,30 @@ module Repo_entity = struct
   module Channel = Model.SelectorType (Channel)
 
   let t =
-    let decode (id, (user_uuid, (channel, (token, ())))) =
-      Ok { id; user_uuid; channel; token }
+    let decode (id, (user_uuid, (channel, (token, (failed_attempts, ()))))) =
+      Ok
+        { id
+        ; user_uuid
+        ; channel
+        ; token
+        ; failed_attempts = FailedAttempts.of_int failed_attempts
+        }
     in
     let encode m : ('a Data.t, string) result =
-      Ok Data.[ m.id; m.user_uuid; m.channel; m.token ]
+      Ok
+        Data.
+          [ m.id
+          ; m.user_uuid
+          ; m.channel
+          ; m.token
+          ; FailedAttempts.value m.failed_attempts
+          ]
     in
     let open Schema in
-    custom ~encode ~decode Caqti_type.[ Id.t; Pool_user.Repo.Id.t; Channel.t; string ]
+    custom
+      ~encode
+      ~decode
+      Caqti_type.[ Id.t; Pool_user.Repo.Id.t; Channel.t; string; int ]
   ;;
 end
 
@@ -23,6 +39,7 @@ let sql_select_columns =
   ; Entity.Id.sql_select_fragment ~field:"pool_authentication.user_uuid"
   ; "pool_authentication.channel"
   ; "pool_authentication.token"
+  ; "pool_authentication.failed_attempts"
   ]
 ;;
 
@@ -33,15 +50,16 @@ let insert_request =
       user_uuid,
       channel,
       token,
+      failed_attempts,
       valid_until
     ) VALUES (
       UNHEX(REPLACE($1, '-', '')),
       UNHEX(REPLACE($2, '-', '')),
       $3,
       $4,
+      $5,
       NOW() + INTERVAL 5 MINUTE
     ) ON DUPLICATE KEY UPDATE
-      uuid = UNHEX(REPLACE($1, '-', '')),
       channel = $3,
       token = $4,
       valid_until = NOW() + INTERVAL 5 MINUTE
@@ -59,8 +77,10 @@ let find_valid_by_id_request =
       FROM pool_authentication
       WHERE uuid = UNHEX(REPLACE($1, '-', ''))
       AND valid_until > NOW()
+      AND failed_attempts < %d
     |sql}
     (CCString.concat ", " sql_select_columns)
+    FailedAttempts.(value limit)
   |> Pool_common.Repo.Id.t ->? Repo_entity.t
 ;;
 
@@ -74,6 +94,22 @@ let find_valid_by_id pool id =
   Lwt_result.return (auth, user)
 ;;
 
+let find_id_by_user_request =
+  Format.asprintf
+    {sql|
+      SELECT
+        %s
+      FROM pool_authentication
+      WHERE user_uuid = UNHEX(REPLACE($1, '-', ''))
+    |sql}
+    (Entity.Id.sql_select_fragment ~field:"pool_authentication.uuid")
+  |> Pool_user.Repo.Id.t ->? Pool_common.Repo.Id.t
+;;
+
+let find_id_by_user pool user_uuid =
+  Database.find_opt pool find_id_by_user_request user_uuid
+;;
+
 let delete_request =
   {sql|
     DELETE FROM pool_authentication
@@ -82,7 +118,20 @@ let delete_request =
   |> Pool_common.Repo.Id.t ->. Caqti_type.unit
 ;;
 
-let delete pool { id; _ } = Database.exec pool delete_request id
+let delete pool id = Database.exec pool delete_request id
+
+let increase_failed_attempts_request =
+  {sql|
+    UPDATE pool_authentication
+    SET failed_attempts = failed_attempts + 1
+    WHERE uuid = UNHEX(REPLACE($1, '-', ''))
+  |sql}
+  |> Pool_common.Repo.Id.t ->. Caqti_type.unit
+;;
+
+let increase_failed_attempts pool { id; _ } =
+  Database.exec pool increase_failed_attempts_request id
+;;
 
 let reset_expired_request =
   {sql|

pool/app/message_template/message_template.ml

@@ -23,6 +23,11 @@ module History = struct
   let user_uuid user = user.Pool_user.id |> Pool_user.Id.to_common
   let admin_item { Admin.user; _ } = User, user_uuid user
   let assignment_item { Assignment.id; _ } = Assignment, Assignment.(id |> Id.to_common)
+
+  let authentication_item { Authentication.id; _ } =
+    Authentication, Pool_common.Id.of_string (Authentication.Id.value id)
+  ;;
+
   let contact_item { Contact.user; _ } = User, user_uuid user
 
   let experiment_item experiment =
@@ -778,7 +783,7 @@ module Login2FAToken = struct
           layout
           (email_params layout user auth.Authentication.token)
       in
-      create_email_job label [] email
+      create_email_job label [ History.authentication_item auth ] email
     in
     Lwt.return fnc
   ;;

pool/app/pool_database/migrations/migration_202607141227.ml

@@ -0,0 +1,45 @@
+open Database
+
+let create_pool_queue_job_authentication_table =
+  Migration.Step.create
+    ~label:"create pool_queue_job_authentication table"
+    {sql|
+      CREATE TABLE IF NOT EXISTS pool_queue_job_authentication (
+        queue_uuid binary(16) NOT NULL,
+        authentication_uuid binary(16) NOT NULL,
+        created_at timestamp NOT NULL DEFAULT CURRENT_TIMESTAMP,
+        updated_at timestamp NOT NULL DEFAULT CURRENT_TIMESTAMP ON UPDATE CURRENT_TIMESTAMP,
+        UNIQUE KEY `unique_queue_uuid` (`queue_uuid`),
+        UNIQUE KEY `unique_queue_entity_combination` (queue_uuid, authentication_uuid),
+        KEY `idx_authentication_uuid` (`authentication_uuid`),
+        CONSTRAINT fk_pool_queue_job_authentication FOREIGN KEY (authentication_uuid) REFERENCES pool_authentication(uuid) ON DELETE CASCADE
+      ) ENGINE=InnoDB DEFAULT CHARSET=utf8mb4 COLLATE=utf8mb4_unicode_ci;
+    |sql}
+;;
+
+let remove_automagic_timestamp_on_update_trigger =
+  Migration.Step.create
+    ~label:
+      "remove mariadbs automagic timestamp on update trigger for token valid_until column"
+    {sql|
+      ALTER TABLE pool_authentication
+      MODIFY COLUMN valid_until TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP()
+    |sql}
+;;
+
+let add_failed_attempts_to_authentication =
+  Migration.Step.create
+    ~label:"add failed_attempts column to pool_authentication"
+    {sql|
+      ALTER TABLE pool_authentication
+      ADD COLUMN failed_attempts TINYINT UNSIGNED NOT NULL DEFAULT 0 AFTER token
+    |sql}
+;;
+
+let migration () =
+  Migration.(
+    empty "202607141227"
+    |> add_step create_pool_queue_job_authentication_table
+    |> add_step remove_automagic_timestamp_on_update_trigger
+    |> add_step add_failed_attempts_to_authentication)
+;;

pool/app/pool_database/root.ml

@@ -35,6 +35,7 @@ let steps =
       ; Migration_202607031400.migration ()
       ; Migration_202607051000.migration ()
       ; Migration_202607061500.migration_root ()
+      ; Migration_202607141227.migration ()
       ]
     |> sort
   in

pool/app/pool_database/tenant.ml

@@ -102,6 +102,7 @@ let steps =
       ; Migration_202607071000.migration ()
       ; Migration_202607071200.migration ()
       ; Migration_202607071300.migration ()
+      ; Migration_202607141227.migration ()
       ]
     |> sort
   in

pool/cqrs_command/login_command.ml

@@ -52,7 +52,7 @@ end = struct
       else Error Pool_message.(Error.Invalid Field.OTP)
     in
     Ok
-      [ Deleted auth |> Pool_event.authentication
+      [ Deleted auth.id |> Pool_event.authentication
       ; ResetExpired |> Pool_event.authentication
       ]
   ;;

pool/pool_queue/entity.ml

@@ -266,6 +266,7 @@ module History = struct
     | Invitation
     | Session
     | User
+    | Authentication
   [@@deriving enum, eq, ord, show, yojson]
 
   let model_sql = function
@@ -274,6 +275,7 @@ module History = struct
     | Invitation -> "pool_queue_job_invitation", "invitation_uuid"
     | Session -> "pool_queue_job_session", "session_uuid"
     | User -> "pool_queue_job_user", "user_uuid"
+    | Authentication -> "pool_queue_job_authentication", "authentication_uuid"
   ;;
 
   let source_table = function
@@ -282,6 +284,7 @@ module History = struct
     | Invitation -> "pool_invitations"
     | Session -> "pool_sessions"
     | User -> "user_users"
+    | Authentication -> "pool_authentication"
   ;;
 
   let all_models : model list =

pool/pool_queue/pool_queue.ml

@@ -30,6 +30,7 @@ let count_all_workable = Repo.count_all_workable
 let count_recently_failed = Repo.count_recently_failed
 let find_instances_by_entity = Repo_mapping.find_instances_by_entity
 let find_related = Repo_mapping.find_related
+let find_last_login_token_sent_at = Repo.find_last_login_token_sent_at
 
 let update_and_return ?history database_label job =
   let%lwt () = Repo.update ?history database_label job in

pool/pool_queue/pool_queue.mli

@@ -152,6 +152,7 @@ module History : sig
     | Invitation
     | Session
     | User
+    | Authentication
 
   type item = model * Pool_common.Id.t
 
@@ -162,6 +163,11 @@ end
 
 val find : Database.Label.t -> Id.t -> (Instance.t, Pool_message.Error.t) Lwt_result.t
 
+val find_last_login_token_sent_at
+  :  Database.Label.t
+  -> Pool_common.Id.t
+  -> Ptime.t option Lwt.t
+
 val find_by
   :  [< `Current | `History ]
   -> ?query:Query.t

pool/pool_queue/repo.ml

@@ -382,6 +382,29 @@ let cancel_undeliverable_email_jobs label =
   Database.exec label cancel_undeliverable_email_jobs_request ()
 ;;
 
+let find_last_login_token_sent_at_request =
+  let open Caqti_request.Infix in
+  let auth_uuid_fragment = Pool_common.Id.sql_value_fragment "?" in
+  [%string
+    {sql|
+       SELECT jobs.persisted_at
+       FROM (
+         SELECT uuid, persisted_at FROM pool_queue_jobs
+         UNION ALL
+         SELECT uuid, persisted_at FROM pool_queue_jobs_history
+       ) AS jobs
+       JOIN pool_queue_job_authentication auth ON auth.queue_uuid = jobs.uuid
+       WHERE auth.authentication_uuid = %{auth_uuid_fragment}
+       ORDER BY jobs.persisted_at DESC
+      LIMIT 1
+    |sql}]
+  |> Pool_common.Repo.Id.t ->? Caqti_type.ptime
+;;
+
+let find_last_login_token_sent_at pool auth_id =
+  Database.find_opt pool find_last_login_token_sent_at_request auth_id
+;;
+
 let find_archivable_request =
   [%string
     {sql|