From d170d7612a9f1f5ba550a628150972e39bfb6891 Mon Sep 17 00:00:00 2001 From: Yannick Koller Date: Fri, 12 Jun 2026 13:11:15 +0200 Subject: [PATCH 01/24] feat: add resend login confirmation token functionality --- pool/routes/routes.ml | 3 ++ pool/web/handler/public_login.ml | 34 +++++++++++++++++++ pool/web/view/page/page_login.ml | 58 ++++++++++++++++++++++++++++++++ 3 files changed, 95 insertions(+) diff --git a/pool/routes/routes.ml b/pool/routes/routes.ml index db809a74c..b286f525d 100644 --- a/pool/routes/routes.ml +++ b/pool/routes/routes.ml @@ -110,6 +110,9 @@ module Public = struct [ get "/login" Login.login_get ; post "/login" Login.login_post ; post "login-confirmation" Login.login_cofirmation + ; post + "/resend-login-confirmation-token" + Login.resend_login_confirmation_token ; get "/request-reset-password" Login.request_reset_password_get ; post "/request-reset-password" Login.request_reset_password_post ; get "/reset-password" Login.reset_password_get diff --git a/pool/web/handler/public_login.ml b/pool/web/handler/public_login.ml index ea4406e70..3a0238a9e 100644 --- a/pool/web/handler/public_login.ml +++ b/pool/web/handler/public_login.ml @@ -170,6 +170,40 @@ let login_cofirmation req = Response.handle ~src req result ;; +let resend_login_confirmation_token req = + let tags = Pool_context.Logger.Tags.req req in + let open Response in + let result ({ Pool_context.database_label; user; _ } as context) = + let* auth_id = + (let%lwt urlencoded = Sihl.Web.Request.to_urlencoded req in + CCList.assoc_opt ~eq:CCString.equal Pool_message.Field.(show Id) urlencoded + |> CCFun.flip CCOption.bind CCList.head_opt + |> CCOption.map Authentication.Id.of_string + |> CCOption.to_result Pool_message.(Error.Invalid Field.Id) + |> Lwt.return) + |> bad_request_on_error login_get + in + let* (_ : Authentication.t), login_user = + Authentication.find_valid_by_id database_label auth_id + |> bad_request_on_error login_get + in + Response.bad_request_render_error context + @@ + let* login_user, (_ : Authentication.t), events = + Helpers_login.create_2fa_auth ~id:auth_id ~tags req context login_user + in + let%lwt () = Pool_event.handle_events database_label user events in + Page.Public.login_token_confirmation + ~authentication_id:auth_id + ?intended:(HttpUtils.find_intended_opt req) + ~email:(Pool_user.email login_user) + context + |> create_layout req ~active_navigation:"/login" context + >|+ Sihl.Web.Response.of_html + in + Response.handle ~src req result +;; + let request_reset_password_get req = let result context = Response.bad_request_render_error context diff --git a/pool/web/view/page/page_login.ml b/pool/web/view/page/page_login.ml index b070d04df..830eb083e 100644 --- a/pool/web/view/page/page_login.ml +++ b/pool/web/view/page/page_login.ml @@ -27,6 +27,63 @@ let login_token_confirmation | Some id -> input_element language `Hidden Pool_message.Field.Id ~value:(Id.value id) | None -> txt "" in + let resend_token = + let cooldown_seconds = 60 in + let resend_action = + HttpUtils.externalize_path_with_params + query_parameters + "/resend-login-confirmation-token" + in + let button_id = "resend-token-button" in + let countdown_id = "resend-token-countdown" in + let js_script = + Format.asprintf + {js| +(() => { + const button = document.getElementById("%s"); + const countdown = document.getElementById("%s"); + if (!button || !countdown) { return; } + button.disabled = true; + const deadline = Date.now() + (parseInt(countdown.dataset.seconds, 10) * 1000); + const update = () => { + const remaining = Math.max(0, Math.ceil((deadline - Date.now()) / 1000)); + if (remaining > 0) { + countdown.textContent = " (" + remaining + ")"; + } else { + countdown.remove(); + button.disabled = false; + clearInterval(interval); + } + }; + const interval = setInterval(update, 1000); + update(); +})(); + |js} + button_id + countdown_id + in + form + ~a:[ a_action resend_action; a_method `Post; a_class [ "stack" ] ] + [ csrf_element csrf () + ; hidden_input + ; div + ~a:[ a_class [ "flexrow"; "align-center"; "flex-gap" ] ] + [ submit_element + ~is_text:true + ~attributes:[ a_id button_id ] + language + (Pool_message.Control.Resend (Some Pool_message.Field.OTP)) + () + ; span + ~a: + [ a_id countdown_id + ; a_user_data "seconds" (Int.to_string cooldown_seconds) + ] + [ txt (Format.asprintf " (%d)" cooldown_seconds) ] + ] + ; script (Unsafe.data js_script) + ] + in div ~a:[ a_class [ "trim"; "narrow"; "safety-margin" ] ] [ h1 @@ -61,6 +118,7 @@ let login_token_confirmation () ] ] + ; resend_token ] ] ;; From f47be8917407070187a902dd31543c44e6c3ea05 Mon Sep 17 00:00:00 2001 From: Yannick Koller Date: Wed, 17 Jun 2026 15:16:22 +0200 Subject: [PATCH 02/24] chore: refactor resend token button --- pool/web/view/page/page_login.ml | 60 ++++++++++++++++++-------------- 1 file changed, 33 insertions(+), 27 deletions(-) diff --git a/pool/web/view/page/page_login.ml b/pool/web/view/page/page_login.ml index 830eb083e..197f9a737 100644 --- a/pool/web/view/page/page_login.ml +++ b/pool/web/view/page/page_login.ml @@ -42,45 +42,51 @@ let login_token_confirmation (() => { const button = document.getElementById("%s"); const countdown = document.getElementById("%s"); - if (!button || !countdown) { return; } + console.log(button); + console.log(countdown); + if (!button || !countdown) { + return; + } + button.disabled = true; + const deadline = Date.now() + (parseInt(countdown.dataset.seconds, 10) * 1000); - const update = () => { + const interval = setInterval(() => { const remaining = Math.max(0, Math.ceil((deadline - Date.now()) / 1000)); + if (remaining > 0) { - countdown.textContent = " (" + remaining + ")"; + countdown.textContent = remaining; } else { - countdown.remove(); button.disabled = false; + countdown.remove(); + clearInterval(interval); } - }; - const interval = setInterval(update, 1000); - update(); + }, 1000); })(); |js} button_id countdown_id in - form - ~a:[ a_action resend_action; a_method `Post; a_class [ "stack" ] ] - [ csrf_element csrf () - ; hidden_input - ; div - ~a:[ a_class [ "flexrow"; "align-center"; "flex-gap" ] ] - [ submit_element - ~is_text:true - ~attributes:[ a_id button_id ] - language - (Pool_message.Control.Resend (Some Pool_message.Field.OTP)) - () - ; span - ~a: - [ a_id countdown_id - ; a_user_data "seconds" (Int.to_string cooldown_seconds) - ] - [ txt (Format.asprintf " (%d)" cooldown_seconds) ] - ] + div + ~a:[ a_class [ "flexrow"; "flex-gap-sm" ] ] + [ button + ~a: + [ a_id button_id + ; a_class [ "btn"; "primary"; "is-text" ] + ; a_style "padding:0" + ; Htmx.hx_post resend_action + ; Htmx.hx_swap "none" + ] + [ txt "Resend verification token" ] + ; span + ~a: + [ a_id countdown_id + ; a_class [ "tag"; "inline" ] + ; a_style "align-content:center" + ; a_user_data "seconds" (Int.to_string cooldown_seconds) + ] + [ txt (Format.asprintf "%d" cooldown_seconds) ] ; script (Unsafe.data js_script) ] in @@ -109,6 +115,7 @@ let login_token_confirmation language `Text Pool_message.Field.OTP + ; resend_token ; div ~a:[ a_class [ "flexrow"; "align-center"; "flex-gap" ] ] [ submit_element @@ -118,7 +125,6 @@ let login_token_confirmation () ] ] - ; resend_token ] ] ;; From 05afdbee052c403d730d083bae2402d7a55991f0 Mon Sep 17 00:00:00 2001 From: Yannick Koller Date: Fri, 19 Jun 2026 15:56:05 +0200 Subject: [PATCH 03/24] feat: load resend timeout from database - implement auth token job log --- pool/app/message_template/message_template.ml | 5 +- .../migrations/migration_202606170000.ml | 21 ++++++ pool/app/pool_database/root.ml | 2 + pool/app/pool_database/tenant.ml | 2 + pool/pool_queue/entity.ml | 3 + pool/pool_queue/pool_queue.ml | 1 + pool/pool_queue/pool_queue.mli | 6 ++ pool/pool_queue/repo.ml | 19 +++++ pool/web/handler/public_login.ml | 28 ++++++-- pool/web/handler/root_login.ml | 4 +- pool/web/view/page/page_login.ml | 71 ++++++++++++------- 11 files changed, 130 insertions(+), 32 deletions(-) create mode 100644 pool/app/pool_database/migrations/migration_202606170000.ml diff --git a/pool/app/message_template/message_template.ml b/pool/app/message_template/message_template.ml index 4412df89f..7015cf467 100644 --- a/pool/app/message_template/message_template.ml +++ b/pool/app/message_template/message_template.ml @@ -23,6 +23,9 @@ 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 +781,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 ;; diff --git a/pool/app/pool_database/migrations/migration_202606170000.ml b/pool/app/pool_database/migrations/migration_202606170000.ml new file mode 100644 index 000000000..c6c306278 --- /dev/null +++ b/pool/app/pool_database/migrations/migration_202606170000.ml @@ -0,0 +1,21 @@ +let create_pool_queue_job_authentication_table = + Database.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), + CONSTRAINT fk_pool_queue_job_authentication FOREIGN KEY (authentication_uuid) REFERENCES pool_authentication(uuid) + ) ENGINE=InnoDB DEFAULT CHARSET=utf8mb4 COLLATE=utf8mb4_unicode_ci; + |sql} +;; + +(* This migration is executed on root and tenant databases *) +let migration () = + Database.Migration.( + empty "202606170000" |> add_step create_pool_queue_job_authentication_table) +;; diff --git a/pool/app/pool_database/root.ml b/pool/app/pool_database/root.ml index 860d8cfa9..191d3ac3a 100644 --- a/pool/app/pool_database/root.ml +++ b/pool/app/pool_database/root.ml @@ -32,6 +32,8 @@ let steps = ; Migration_202505121331.migration () ; Migration_202506261422.migration () ; Migration_202603061300.migration () + ; Migration_202606170000.migration () + ; Migration_202607031200.migration () ; Migration_202607031400.migration () ; Migration_202607051000.migration () ; Migration_202607061500.migration_root () diff --git a/pool/app/pool_database/tenant.ml b/pool/app/pool_database/tenant.ml index 9be348b30..ab81255d6 100644 --- a/pool/app/pool_database/tenant.ml +++ b/pool/app/pool_database/tenant.ml @@ -96,6 +96,8 @@ let steps = ; Migration_202604200000.migration () ; Migration_202605110000.migration () ; Migration_202605291200.migration () + ; Migration_202606170000.migration () + ; Migration_202607031200.migration () ; Migration_202607031400.migration () ; Migration_202607051000.migration () ; Migration_202607061500.migration () diff --git a/pool/pool_queue/entity.ml b/pool/pool_queue/entity.ml index 5cb7db23d..7af7b3e93 100644 --- a/pool/pool_queue/entity.ml +++ b/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 = diff --git a/pool/pool_queue/pool_queue.ml b/pool/pool_queue/pool_queue.ml index 8dd27063e..e40e18705 100644 --- a/pool/pool_queue/pool_queue.ml +++ b/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 diff --git a/pool/pool_queue/pool_queue.mli b/pool/pool_queue/pool_queue.mli index 62e6542f3..784b91745 100644 --- a/pool/pool_queue/pool_queue.mli +++ b/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 diff --git a/pool/pool_queue/repo.ml b/pool/pool_queue/repo.ml index 97ba4c6d8..b22cf7b61 100644 --- a/pool/pool_queue/repo.ml +++ b/pool/pool_queue/repo.ml @@ -361,6 +361,25 @@ 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 persisted_at + FROM pool_queue_jobs_history + JOIN pool_queue_job_authentication ON queue_uuid = uuid + WHERE authentication_uuid = %{auth_uuid_fragment} + ORDER BY 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| diff --git a/pool/web/handler/public_login.ml b/pool/web/handler/public_login.ml index 3a0238a9e..d747ec95a 100644 --- a/pool/web/handler/public_login.ml +++ b/pool/web/handler/public_login.ml @@ -46,7 +46,7 @@ let login_token_confirmation req = ?intended:(HttpUtils.find_intended_opt req) ~email:(Pool_user.email user) context - |> create_layout req ~active_navigation:"/login" context + >|> create_layout req ~active_navigation:"/login" context >|+ Sihl.Web.Response.of_html) in Response.handle ~src req result @@ -68,7 +68,7 @@ let login_post req = ?intended:(HttpUtils.find_intended_opt req) ~email:(Pool_user.email login_user) context - |> create_layout req ~active_navigation:"/login" context + >|> create_layout req ~active_navigation:"/login" context >|+ Sihl.Web.Response.of_html in events |> handle_events >|> success @@ -173,6 +173,7 @@ let login_cofirmation req = let resend_login_confirmation_token req = let tags = Pool_context.Logger.Tags.req req in let open Response in + let cooldown_seconds = 60 in let result ({ Pool_context.database_label; user; _ } as context) = let* auth_id = (let%lwt urlencoded = Sihl.Web.Request.to_urlencoded req in @@ -187,8 +188,27 @@ let resend_login_confirmation_token req = Authentication.find_valid_by_id database_label auth_id |> bad_request_on_error login_get in - Response.bad_request_render_error context + bad_request_on_error login_token_confirmation @@ + let* () = + let%lwt last_sent_at = + Pool_queue.find_last_login_token_sent_at + database_label + (Pool_common.Id.of_string (Authentication.Id.value auth_id)) + in + (match last_sent_at with + | None -> Ok () + | Some sent_at -> + let elapsed = + Ptime.diff (Ptime_clock.now ()) sent_at + |> Ptime.Span.to_float_s + |> int_of_float + in + if elapsed < cooldown_seconds + then Error Pool_message.Error.TokenAlreadySentRecently + else Ok ()) + |> Lwt_result.lift + in let* login_user, (_ : Authentication.t), events = Helpers_login.create_2fa_auth ~id:auth_id ~tags req context login_user in @@ -198,7 +218,7 @@ let resend_login_confirmation_token req = ?intended:(HttpUtils.find_intended_opt req) ~email:(Pool_user.email login_user) context - |> create_layout req ~active_navigation:"/login" context + >|> create_layout req ~active_navigation:"/login" context >|+ Sihl.Web.Response.of_html in Response.handle ~src req result diff --git a/pool/web/handler/root_login.ml b/pool/web/handler/root_login.ml index cae27a3bd..10af9d91b 100644 --- a/pool/web/handler/root_login.ml +++ b/pool/web/handler/root_login.ml @@ -39,7 +39,7 @@ let login_token_confirmation req = ?intended:(HttpUtils.find_intended_opt req) ~email:(Pool_user.email user) context - |> General.create_root_layout ~active_navigation:"/root/login" context + >|> General.create_root_layout ~active_navigation:"/root/login" context ||> Sihl.Web.Response.of_html |> Lwt_result.ok in @@ -62,7 +62,7 @@ let login_post req = ?intended:(HttpUtils.find_intended_opt req) ~email:(Pool_user.email user) context - |> General.create_root_layout ~active_navigation:"/root/login" context + >|> General.create_root_layout ~active_navigation:"/root/login" context ||> Sihl.Web.Response.of_html in events |> handle_events >|> success |> Lwt_result.ok diff --git a/pool/web/view/page/page_login.ml b/pool/web/view/page/page_login.ml index 197f9a737..6b4e19cfd 100644 --- a/pool/web/view/page/page_login.ml +++ b/pool/web/view/page/page_login.ml @@ -9,12 +9,13 @@ let query_params_with_intended query_parameters intended = ;; let login_token_confirmation - Pool_context.{ language; query_parameters; csrf; _ } + Pool_context.{ language; query_parameters; csrf; database_label; _ } ?authentication_id ~email ?intended url = + let open Utils.Lwt_result.Infix in let query_parameters = query_params_with_intended query_parameters intended in let action = HttpUtils.externalize_path_with_params query_parameters url in let hint = @@ -27,8 +28,17 @@ let login_token_confirmation | Some id -> input_element language `Hidden Pool_message.Field.Id ~value:(Id.value id) | None -> txt "" in - let resend_token = + let resend_token sent_at = let cooldown_seconds = 60 in + let remaining_seconds = + match sent_at with + | None -> 0 + | Some t -> + let elapsed = + Ptime.diff (Ptime_clock.now ()) t |> Ptime.Span.to_float_s |> int_of_float + in + max 0 (cooldown_seconds - elapsed) + in let resend_action = HttpUtils.externalize_path_with_params query_parameters @@ -42,9 +52,7 @@ let login_token_confirmation (() => { const button = document.getElementById("%s"); const countdown = document.getElementById("%s"); - console.log(button); - console.log(countdown); - if (!button || !countdown) { + if (!button || !countdown) { return; } @@ -59,7 +67,7 @@ let login_token_confirmation } else { button.disabled = false; countdown.remove(); - + clearInterval(interval); } }, 1000); @@ -70,26 +78,39 @@ let login_token_confirmation in div ~a:[ a_class [ "flexrow"; "flex-gap-sm" ] ] - [ button - ~a: - [ a_id button_id - ; a_class [ "btn"; "primary"; "is-text" ] - ; a_style "padding:0" - ; Htmx.hx_post resend_action - ; Htmx.hx_swap "none" - ] - [ txt "Resend verification token" ] - ; span - ~a: - [ a_id countdown_id - ; a_class [ "tag"; "inline" ] - ; a_style "align-content:center" - ; a_user_data "seconds" (Int.to_string cooldown_seconds) - ] - [ txt (Format.asprintf "%d" cooldown_seconds) ] - ; script (Unsafe.data js_script) - ] + ([ button + ~a: + [ a_id button_id + ; a_class [ "btn"; "primary"; "is-text" ] + ; a_style "padding:0" + ; Htmx.hx_post resend_action + ; Htmx.hx_swap "none" + ] + [ txt "Resend verification token" ] + ] + @ + if remaining_seconds > 0 + then + [ span + ~a: + [ a_id countdown_id + ; a_class [ "tag"; "inline" ] + ; a_style "align-content:center" + ; a_user_data "seconds" (Int.to_string remaining_seconds) + ] + [ txt (Int.to_string remaining_seconds) ] + ; script (Unsafe.data js_script) + ] + else []) in + (match authentication_id with + | None -> Lwt.return (txt "") + | Some id -> + Pool_queue.find_last_login_token_sent_at + database_label + (Pool_common.Id.of_string (Authentication.Id.value id)) + ||> resend_token) + ||> fun resend_token -> div ~a:[ a_class [ "trim"; "narrow"; "safety-margin" ] ] [ h1 From b31e96e23d4d496a58ec54778b5f4c350bb37c11 Mon Sep 17 00:00:00 2001 From: Yannick Koller Date: Mon, 22 Jun 2026 12:43:24 +0200 Subject: [PATCH 04/24] chore: format message_template.ml --- pool/app/message_template/message_template.ml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/pool/app/message_template/message_template.ml b/pool/app/message_template/message_template.ml index 7015cf467..5030082c8 100644 --- a/pool/app/message_template/message_template.ml +++ b/pool/app/message_template/message_template.ml @@ -23,9 +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 = From 0a8a048d80e5562ce68ef610474b810e9ff91d14 Mon Sep 17 00:00:00 2001 From: Yannick Koller Date: Mon, 22 Jun 2026 16:09:36 +0200 Subject: [PATCH 05/24] chore: cascade 2fa token deletions to email job history --- pool/app/pool_database/migrations/migration_202606170000.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/pool/app/pool_database/migrations/migration_202606170000.ml b/pool/app/pool_database/migrations/migration_202606170000.ml index c6c306278..ac0754f6e 100644 --- a/pool/app/pool_database/migrations/migration_202606170000.ml +++ b/pool/app/pool_database/migrations/migration_202606170000.ml @@ -9,7 +9,7 @@ let create_pool_queue_job_authentication_table = 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), - CONSTRAINT fk_pool_queue_job_authentication FOREIGN KEY (authentication_uuid) REFERENCES pool_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} ;; From 125ecc895b508f9143b3b02981f6d7c7d62a6bc5 Mon Sep 17 00:00:00 2001 From: Yannick Koller Date: Mon, 22 Jun 2026 16:10:46 +0200 Subject: [PATCH 06/24] fix: do not update pool_authentication primary key on duplicate key --- pool/app/authentication/repo.ml | 1 - 1 file changed, 1 deletion(-) diff --git a/pool/app/authentication/repo.ml b/pool/app/authentication/repo.ml index 2d12fcfe7..074bfe2e5 100644 --- a/pool/app/authentication/repo.ml +++ b/pool/app/authentication/repo.ml @@ -41,7 +41,6 @@ let insert_request = $4, NOW() + INTERVAL 5 MINUTE ) ON DUPLICATE KEY UPDATE - uuid = UNHEX(REPLACE($1, '-', '')), channel = $3, token = $4, valid_until = NOW() + INTERVAL 5 MINUTE From 021f1c95cf462de2a2f931752f6bb5ced63980a6 Mon Sep 17 00:00:00 2001 From: Yannick Koller Date: Tue, 7 Jul 2026 16:23:56 +0200 Subject: [PATCH 07/24] feat: rework 2FA process - split login and 2FA verification over 2 pages - track 2FA token usage and fail login if limit is reached --- pool/app/authentication/authentication.ml | 2 +- pool/app/authentication/authentication.mli | 13 + pool/app/authentication/entity.ml | 7 + pool/app/authentication/event.ml | 2 + pool/app/authentication/repo.ml | 29 +- .../migrations/migration_202607031200.ml | 14 + pool/app/pool_database/root.ml | 1 + pool/app/pool_database/tenant.ml | 1 + pool/routes/routes.ml | 6 +- pool/web/handler/helpers_login.ml | 69 ++++ pool/web/handler/public_login.ml | 305 ++++++++++-------- pool/web/handler/root_login.ml | 89 ++--- pool/web/view/page/page_public.ml | 6 +- pool/web/view/page/page_root_login.ml | 2 +- 14 files changed, 359 insertions(+), 187 deletions(-) create mode 100644 pool/app/pool_database/migrations/migration_202607031200.ml diff --git a/pool/app/authentication/authentication.ml b/pool/app/authentication/authentication.ml index 2f760a8fc..f040a39dd 100644 --- a/pool/app/authentication/authentication.ml +++ b/pool/app/authentication/authentication.ml @@ -5,7 +5,7 @@ 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; usage_count = UsageCount.of_int 0 } ;; let find_valid_by_id = Repo.find_valid_by_id diff --git a/pool/app/authentication/authentication.mli b/pool/app/authentication/authentication.mli index 8fd619f1d..c4a9b66e5 100644 --- a/pool/app/authentication/authentication.mli +++ b/pool/app/authentication/authentication.mli @@ -21,11 +21,23 @@ module Token : sig val schema : unit -> (Pool_conformist.error_msg, t) Pool_conformist.Field.t end +module UsageCount : 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 + ; usage_count : UsageCount.t } val equal : t -> t -> bool @@ -43,6 +55,7 @@ val create type event = | Created of t | Deleted of t + | IncreaseUsageCount of t | ResetExpired val equal_event : event -> event -> bool diff --git a/pool/app/authentication/entity.ml b/pool/app/authentication/entity.ml index 56b06020b..fd26da13b 100644 --- a/pool/app/authentication/entity.ml +++ b/pool/app/authentication/entity.ml @@ -18,6 +18,12 @@ module Channel = struct include Core end +module UsageCount = struct + include Pool_model.Base.Integer + + let limit = of_int 3 +end + module Token = struct include Pool_model.Base.String @@ -47,5 +53,6 @@ type t = ; user_uuid : Pool_user.Id.t ; channel : Channel.t ; token : Token.t + ; usage_count : UsageCount.t } [@@deriving eq, show { with_path = false }] diff --git a/pool/app/authentication/event.ml b/pool/app/authentication/event.ml index 21e3a8bff..f52ba23cf 100644 --- a/pool/app/authentication/event.ml +++ b/pool/app/authentication/event.ml @@ -3,11 +3,13 @@ open Entity type event = | Created of t | Deleted of t + | IncreaseUsageCount of t | ResetExpired [@@deriving eq, show] let handle_event pool = function | Created t -> Repo.insert pool t | Deleted t -> Repo.delete pool t + | IncreaseUsageCount t -> Repo.increase_usage_count pool t | ResetExpired -> Repo.reset_expired pool () ;; diff --git a/pool/app/authentication/repo.ml b/pool/app/authentication/repo.ml index 074bfe2e5..bf668c8a8 100644 --- a/pool/app/authentication/repo.ml +++ b/pool/app/authentication/repo.ml @@ -7,14 +7,17 @@ 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, (usage_count, ()))))) = + Ok { id; user_uuid; channel; token; usage_count = UsageCount.of_int usage_count } 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; UsageCount.value m.usage_count ] 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 +26,7 @@ let sql_select_columns = ; Entity.Id.sql_select_fragment ~field:"pool_authentication.user_uuid" ; "pool_authentication.channel" ; "pool_authentication.token" + ; "pool_authentication.usage_count" ] ;; @@ -33,12 +37,14 @@ let insert_request = user_uuid, channel, token, + usage_count, valid_until ) VALUES ( UNHEX(REPLACE($1, '-', '')), UNHEX(REPLACE($2, '-', '')), $3, $4, + $5, NOW() + INTERVAL 5 MINUTE ) ON DUPLICATE KEY UPDATE channel = $3, @@ -58,8 +64,10 @@ let find_valid_by_id_request = FROM pool_authentication WHERE uuid = UNHEX(REPLACE($1, '-', '')) AND valid_until > NOW() + AND usage_count < %d |sql} (CCString.concat ", " sql_select_columns) + UsageCount.(value limit) |> Pool_common.Repo.Id.t ->? Repo_entity.t ;; @@ -83,6 +91,19 @@ let delete_request = let delete pool { id; _ } = Database.exec pool delete_request id +let increase_usage_count_request = + {sql| + UPDATE pool_authentication + SET usage_count = usage_count + 1 + WHERE uuid = UNHEX(REPLACE($1, '-', '')) + |sql} + |> Pool_common.Repo.Id.t ->. Caqti_type.unit +;; + +let increase_usage_count pool { id; _ } = + Database.exec pool increase_usage_count_request id +;; + let reset_expired_request = {sql| DELETE FROM pool_authentication diff --git a/pool/app/pool_database/migrations/migration_202607031200.ml b/pool/app/pool_database/migrations/migration_202607031200.ml new file mode 100644 index 000000000..beefb7d54 --- /dev/null +++ b/pool/app/pool_database/migrations/migration_202607031200.ml @@ -0,0 +1,14 @@ +let add_usage_count_to_authentication = + Database.Migration.Step.create + ~label:"add usage_count to pool_authentication" + {sql| + ALTER TABLE pool_authentication + MODIFY COLUMN valid_until TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP(), + ADD COLUMN usage_count TINYINT UNSIGNED NOT NULL AFTER token + |sql} +;; + +(* This migration is executed on root and tenant databases *) +let migration () = + Database.Migration.(empty "202607031200" |> add_step add_usage_count_to_authentication) +;; diff --git a/pool/app/pool_database/root.ml b/pool/app/pool_database/root.ml index 191d3ac3a..66dbb59c3 100644 --- a/pool/app/pool_database/root.ml +++ b/pool/app/pool_database/root.ml @@ -37,6 +37,7 @@ let steps = ; Migration_202607031400.migration () ; Migration_202607051000.migration () ; Migration_202607061500.migration_root () + ; Migration_202607031200.migration () ] |> sort in diff --git a/pool/app/pool_database/tenant.ml b/pool/app/pool_database/tenant.ml index ab81255d6..29083da58 100644 --- a/pool/app/pool_database/tenant.ml +++ b/pool/app/pool_database/tenant.ml @@ -101,6 +101,7 @@ let steps = ; Migration_202607031400.migration () ; Migration_202607051000.migration () ; Migration_202607061500.migration () + ; Migration_202607031200.migration () ] |> sort in diff --git a/pool/routes/routes.ml b/pool/routes/routes.ml index b286f525d..6283662ee 100644 --- a/pool/routes/routes.ml +++ b/pool/routes/routes.ml @@ -109,7 +109,8 @@ module Public = struct ] [ get "/login" Login.login_get ; post "/login" Login.login_post - ; post "login-confirmation" Login.login_cofirmation + ; get "/login/verify" Login.login_verify_get + ; post "/login/verify" Login.login_verify_post ; post "/resend-login-confirmation-token" Login.resend_login_confirmation_token @@ -995,7 +996,8 @@ module Root = struct let open Handler.Root in [ get "/login" Login.login_get ; post "/login" Login.login_post - ; post "/login-confirmation" Login.confirmation_post + ; get "/login/verify" Login.login_verify_get + ; post "/login/verify" Login.login_verify_post ; get "/request-reset-password" Login.request_reset_password_get ; post "/request-reset-password" Login.request_reset_password_post ; get "/reset-password" Login.reset_password_get diff --git a/pool/web/handler/helpers_login.ml b/pool/web/handler/helpers_login.ml index c5d03f542..e0bc609f1 100644 --- a/pool/web/handler/helpers_login.ml +++ b/pool/web/handler/helpers_login.ml @@ -261,3 +261,72 @@ let confirm_2fa_login ~tags user authentication token req = in Lwt_result.return (user, events) ;; + +(* Register a failed login attempt for [email], increasing the block duration and + notifying the user if the account gets (temporarily) suspended. Mirrors the + counter handling in [validate_login]. *) +let increment_failed_login_attempt ~tags database_label email = + let open Pool_user.FailedLoginAttempt in + let%lwt login_attempts = Repo.find_opt database_label email in + let counter = + match login_attempts with + | Some { counter; _ } -> counter + | None -> Counter.init + in + let counter = Counter.increment counter in + let blocked_until = block_until counter in + let m = + match login_attempts with + | None -> create email counter blocked_until + | Some login_attempts -> { login_attempts with counter; blocked_until } + in + let%lwt () = Repo.insert database_label m in + notify_user database_label tags email blocked_until +;; + +type verify_outcome = + | Verified of Pool_user.t + | InvalidToken of Pool_message.Error.t + | SessionExpired + +let verify_2fa_login ~tags { Pool_context.database_label; user = context_user; _ } req = + match Sihl.Web.Session.find "auth_id" req with + | None -> Lwt.return SessionExpired + | Some auth_id -> + Authentication.Id.of_string auth_id + |> Authentication.find_valid_by_id database_label + >|> (function + | Error _ -> Lwt.return SessionExpired + | Ok (auth, user) -> + let%lwt urlencoded = Sihl.Web.Request.to_urlencoded req in + (match Cqrs_command.Login_command.Confirm2FaLogin.decode urlencoded with + | Error err -> Lwt.return (InvalidToken err) + | Ok (_, token) -> + confirm_2fa_login ~tags user auth token req + >|> (function + | Ok (user, events) -> + let%lwt () = Pool_event.handle_events database_label context_user events in + Lwt.return (Verified user) + | Error err -> + let%lwt () = + Pool_event.handle_events + database_label + context_user + [ Authentication.IncreaseUsageCount auth |> Pool_event.authentication ] + in + let remaining = + Authentication.UsageCount.(value limit) + - Authentication.UsageCount.value auth.Authentication.usage_count + - 1 + in + if remaining <= 0 + then ( + let%lwt () = + increment_failed_login_attempt + ~tags + database_label + (Pool_user.email user) + in + Lwt.return SessionExpired) + else Lwt.return (InvalidToken err)))) +;; diff --git a/pool/web/handler/public_login.ml b/pool/web/handler/public_login.ml index d747ec95a..692eddaf6 100644 --- a/pool/web/handler/public_login.ml +++ b/pool/web/handler/public_login.ml @@ -32,44 +32,23 @@ let login_get req = Response.handle ~src req result ;; -let login_token_confirmation req = - let tags = Pool_context.Logger.Tags.req req in - let open Response in - let result ({ Pool_context.database_label; _ } as context) = - let* user, auth, (_ : Authentication.Token.t) = - Helpers_login.decode_2fa_confirmation database_label req ~tags - |> bad_request_on_error login_get - in - Response.bad_request_render_error context - @@ (Page.Public.login_token_confirmation - ~authentication_id:auth.Authentication.id - ?intended:(HttpUtils.find_intended_opt req) - ~email:(Pool_user.email user) - context - >|> create_layout req ~active_navigation:"/login" context - >|+ Sihl.Web.Response.of_html) - in - Response.handle ~src req result -;; - let login_post req = let tags = Pool_context.Logger.Tags.req req in let%lwt urlencoded = Sihl.Web.Request.to_urlencoded req in - let result ({ Pool_context.database_label; user; query_parameters; _ } as context) = + let result (Pool_context.{ database_label; user; query_parameters; _ } as context) = Response.bad_request_on_error ~urlencoded login_get @@ let* login_step = Helpers_login.initiate_login ~tags req context urlencoded in match login_step with - | Helpers_login.MfaRequired (login_user, auth, events) -> + | Helpers_login.MfaRequired (_, auth, events) -> let handle_events = Pool_event.handle_events database_label user in let success () = - Page.Public.login_token_confirmation - ~authentication_id:auth.Authentication.id - ?intended:(HttpUtils.find_intended_opt req) - ~email:(Pool_user.email login_user) - context - >|> create_layout req ~active_navigation:"/login" context - >|+ Sihl.Web.Response.of_html + HttpUtils.redirect_to_with_actions + "/login/verify" + [ Sihl.Web.Session.set + [ "auth_id", auth.Authentication.id |> Authentication.Id.value ] + ] + |> Lwt_result.ok in events |> handle_events >|> success | Helpers_login.DirectLogin login_user -> @@ -96,132 +75,186 @@ let login_post req = Response.handle ~src req result ;; -let login_cofirmation req = +let login_verify_get req = + let tags = Pool_context.Logger.Tags.req req in + let handle_request (Pool_context.{ database_label; _ } as context) = + let handle_auth auth_id user = + Page.Public.login_token_confirmation + ~authentication_id:auth_id + ?intended:(HttpUtils.find_intended_opt req) + ~email:(Pool_user.email user) + context + >|> create_layout req ~active_navigation:"/login" context + >|+ Sihl.Web.Response.of_html + in + (match Sihl.Web.Session.find "auth_id" req with + | None -> Lwt_result.fail () + | Some auth_id -> + Authentication.Id.of_string auth_id + |> Authentication.find_valid_by_id database_label + >|+ (fun (_, user) -> Authentication.Id.of_string auth_id, user) + >>= (fun (auth_id, user) -> handle_auth auth_id user) + >|- fun _ -> + let _ = + Pool_common.Utils.with_log_error + ~tags + (Pool_message.Error.Authorization "Failed to authenticate user") + in + ()) + >|> function + | Ok ok -> Lwt_result.return ok + | Error () -> + HttpUtils.redirect_to_with_actions + "/login" + [ Sihl.Web.Session.update_or_set_value ~key:"auth_id" (fun _ -> None) req + ; Message.set + ~warning: + [ Pool_message.Warning.Warning + "Your session has expired, please sign in again" + ] + ] + |> Lwt_result.ok + in + Response.handle ~src req handle_request +;; + +let login_verify_post req = let open Response in let open HttpUtils in let tags = Pool_context.Logger.Tags.req req in - let result { Pool_context.database_label; query_parameters; _ } = - let* user, auth, token = - Helpers_login.decode_2fa_confirmation database_label req ~tags - |> bad_request_on_error login_get - in - bad_request_on_error login_token_confirmation - @@ - let* user, events = Helpers_login.confirm_2fa_login ~tags user auth token req in - let success_and_redirect - ?(set_completion_cookie = false) - ?redirect - ?(actions = []) - context_user - = - let redirect = - let open CCOption in - redirect - <+> find_intended_opt req - |> value ~default:(Pool_context.dashboard_path context_user) - |> url_with_field_params query_parameters - in - let tags = Pool_context.Logger.Tags.req req in - let%lwt () = Pool_event.handle_events database_label context_user events in - let* () = increase_sign_in_count ~tags database_label context_user in + let handle_request ({ Pool_context.database_label; query_parameters; _ } as context) = + let session_expired () = redirect_to_with_actions - redirect - ([ Sihl.Web.Session.set [ "user_id", user.Pool_user.id |> Pool_user.Id.value ] ] - @ actions) - ||> (fun res -> - if set_completion_cookie - then - Sihl.Web.Session.set_value ~key:Contact.profile_completion_cookie "true" req res - else res) + "/login" + [ Message.set + ~warning: + [ Pool_message.Warning.Warning + "Your session has expired, please sign in again" + ] + ] |> Lwt_result.ok in - let handle_admin_login user = - user.Pool_user.id - |> Admin.(Id.of_user %> find database_label) - >|+ Pool_context.admin - >>= success_and_redirect - in - let handle_contact_login user = - let* contact = user.Pool_user.id |> Contact.(Id.of_user %> find database_label) in - let%lwt required_answers_given = - Custom_field.all_required_answered database_label (Contact.id contact) + let login user = + let success_and_redirect + ?(set_completion_cookie = false) + ?redirect + ?(actions = []) + context_user + = + let redirect = + let open CCOption in + redirect + <+> find_intended_opt req + |> value ~default:(Pool_context.dashboard_path context_user) + |> url_with_field_params query_parameters + in + let* () = increase_sign_in_count ~tags database_label context_user in + redirect_to_with_actions + redirect + ([ Sihl.Web.Session.set [ "user_id", user.Pool_user.id |> Pool_user.Id.value ] ] + @ actions) + ||> (fun res -> + if set_completion_cookie + then + Sihl.Web.Session.set_value ~key:Contact.profile_completion_cookie "true" req res + else res) + |> Lwt_result.ok + in + let handle_admin_login user = + user.Pool_user.id + |> Admin.(Id.of_user %> find database_label) + >|+ Pool_context.admin + >>= success_and_redirect in - let contact = contact |> Pool_context.contact in - match required_answers_given with - | true -> success_and_redirect contact + let handle_contact_login user = + let* contact = user.Pool_user.id |> Contact.(Id.of_user %> find database_label) in + let%lwt required_answers_given = + Custom_field.all_required_answered database_label (Contact.id contact) + in + let contact = contact |> Pool_context.contact in + match required_answers_given with + | true -> success_and_redirect contact + | false -> + success_and_redirect + ~set_completion_cookie:true + ~redirect:"/user/completion" + ~actions:[ Message.set ~error:[ Pool_message.Error.RequiredFieldsMissing ] ] + contact + in + match user |> Pool_user.is_confirmed with | false -> - success_and_redirect - ~set_completion_cookie:true - ~redirect:"/user/completion" - ~actions:[ Message.set ~error:[ Pool_message.Error.RequiredFieldsMissing ] ] - contact + redirect_to (url_with_field_params query_parameters "/email-confirmation") + |> Lwt_result.ok + | true -> + user + |> Admin.user_is_admin database_label + >|> (function + | true -> handle_admin_login user + | false -> handle_contact_login user) in - match user |> Pool_user.is_confirmed with - | false -> - redirect_to (url_with_field_params query_parameters "/email-confirmation") + Helpers_login.verify_2fa_login ~tags context req + >|> function + | Helpers_login.Verified user -> bad_request_on_error login_verify_get @@ login user + | Helpers_login.InvalidToken _ -> + HttpUtils.redirect_to_with_actions + "/login/verify" + [ Message.set ~error:[ Pool_message.(Error.Invalid Field.OTP) ] ] |> Lwt_result.ok - | true -> - user - |> Admin.user_is_admin database_label - >|> (function - | true -> handle_admin_login user - | false -> handle_contact_login user) + | Helpers_login.SessionExpired -> session_expired () in - Response.handle ~src req result + Response.handle ~src req handle_request ;; let resend_login_confirmation_token req = let tags = Pool_context.Logger.Tags.req req in - let open Response in let cooldown_seconds = 60 in - let result ({ Pool_context.database_label; user; _ } as context) = - let* auth_id = - (let%lwt urlencoded = Sihl.Web.Request.to_urlencoded req in - CCList.assoc_opt ~eq:CCString.equal Pool_message.Field.(show Id) urlencoded - |> CCFun.flip CCOption.bind CCList.head_opt - |> CCOption.map Authentication.Id.of_string - |> CCOption.to_result Pool_message.(Error.Invalid Field.Id) - |> Lwt.return) - |> bad_request_on_error login_get - in - let* (_ : Authentication.t), login_user = - Authentication.find_valid_by_id database_label auth_id - |> bad_request_on_error login_get - in - bad_request_on_error login_token_confirmation - @@ - let* () = - let%lwt last_sent_at = - Pool_queue.find_last_login_token_sent_at - database_label - (Pool_common.Id.of_string (Authentication.Id.value auth_id)) + let handle_request ({ Pool_context.database_label; user; _ } as context) = + let%lwt result = + let* auth_id = + let%lwt urlencoded = Sihl.Web.Request.to_urlencoded req in + CCList.assoc_opt ~eq:CCString.equal Pool_message.Field.(show Id) urlencoded + |> CCFun.flip CCOption.bind CCList.head_opt + |> CCOption.map Authentication.Id.of_string + |> CCOption.to_result Pool_message.(Error.Invalid Field.Id) + |> Lwt.return in - (match last_sent_at with - | None -> Ok () - | Some sent_at -> - let elapsed = - Ptime.diff (Ptime_clock.now ()) sent_at - |> Ptime.Span.to_float_s - |> int_of_float - in - if elapsed < cooldown_seconds - then Error Pool_message.Error.TokenAlreadySentRecently - else Ok ()) - |> Lwt_result.lift - in - let* login_user, (_ : Authentication.t), events = - Helpers_login.create_2fa_auth ~id:auth_id ~tags req context login_user + let* (_ : Authentication.t), login_user = + Authentication.find_valid_by_id database_label auth_id + in + let* () = + let%lwt last_sent_at = + Pool_queue.find_last_login_token_sent_at + database_label + (Pool_common.Id.of_string (Authentication.Id.value auth_id)) + in + (match last_sent_at with + | None -> Ok () + | Some sent_at -> + let elapsed = + Ptime.diff (Ptime_clock.now ()) sent_at + |> Ptime.Span.to_float_s + |> int_of_float + in + if elapsed < cooldown_seconds + then Error Pool_message.Error.TokenAlreadySentRecently + else Ok ()) + |> Lwt_result.lift + in + let* _, (_ : Authentication.t), events = + Helpers_login.create_2fa_auth ~id:auth_id ~tags req context login_user + in + let%lwt () = Pool_event.handle_events database_label user events in + Lwt.return_ok () in - let%lwt () = Pool_event.handle_events database_label user events in - Page.Public.login_token_confirmation - ~authentication_id:auth_id - ?intended:(HttpUtils.find_intended_opt req) - ~email:(Pool_user.email login_user) - context - >|> create_layout req ~active_navigation:"/login" context - >|+ Sihl.Web.Response.of_html + Http_response.Htmx.redirect + "/login/verify" + ~actions: + (match result with + | Ok _ -> [ Message.set ~success:[ Pool_message.(Success.Resent Field.OTP) ] ] + | Error e -> [ Message.set ~error:[ e ] ]) + |> Lwt_result.ok in - Response.handle ~src req result + Response.handle ~src req handle_request ;; let request_reset_password_get req = diff --git a/pool/web/handler/root_login.ml b/pool/web/handler/root_login.ml index 10af9d91b..34a2c46ed 100644 --- a/pool/web/handler/root_login.ml +++ b/pool/web/handler/root_login.ml @@ -6,6 +6,7 @@ module Response = Http_response let src = Logs.Src.create "handler.root.login" let root_login_path = "/root/login" +let root_login_verify_path = "/root/login/verify" let root_entrypoint_path = Http_utils.Url.Root.pool_path () let redirect_to_entrypoint = HttpUtils.redirect_to root_entrypoint_path @@ -26,26 +27,6 @@ let login_get req = Response.handle ~src req result ;; -let login_token_confirmation req = - let tags = Pool_context.Logger.Tags.req req in - let open Response in - let result ({ Pool_context.database_label; _ } as context) = - let* user, auth, (_ : Authentication.Token.t) = - Helpers_login.decode_2fa_confirmation database_label req ~tags - |> bad_request_on_error login_get - in - Page.Root.Login.token_confirmation - ~authentication_id:auth.Authentication.id - ?intended:(HttpUtils.find_intended_opt req) - ~email:(Pool_user.email user) - context - >|> General.create_root_layout ~active_navigation:"/root/login" context - ||> Sihl.Web.Response.of_html - |> Lwt_result.ok - in - Response.handle ~src req result -;; - let login_post req = let tags = Pool_context.Logger.Tags.req req in let%lwt urlencoded = Sihl.Web.Request.to_urlencoded req in @@ -53,44 +34,76 @@ let login_post req = Response.bad_request_on_error ~urlencoded login_get @@ let handle_events = Pool_event.handle_events database_label user in - let* user, auth, events = + let* (_ : Pool_user.t), auth, events = Helpers_login.create_2fa_login ~tags req context urlencoded in let success () = + HttpUtils.redirect_to_with_actions + (HttpUtils.retain_url_params req root_login_verify_path |> Uri.to_string) + [ Sihl.Web.Session.set + [ "auth_id", auth.Authentication.id |> Authentication.Id.value ] + ] + in + events |> handle_events >|> success |> Lwt_result.ok + in + Response.handle ~src req result +;; + +let login_verify_get req = + let result (Pool_context.{ database_label; _ } as context) = + let handle_auth auth_id user = Page.Root.Login.token_confirmation - ~authentication_id:auth.Authentication.id + ~authentication_id:auth_id ?intended:(HttpUtils.find_intended_opt req) ~email:(Pool_user.email user) context >|> General.create_root_layout ~active_navigation:"/root/login" context ||> Sihl.Web.Response.of_html + |> Lwt_result.ok in - events |> handle_events >|> success |> Lwt_result.ok + (match Sihl.Web.Session.find "auth_id" req with + | None -> Lwt_result.fail () + | Some auth_id -> + Authentication.Id.of_string auth_id + |> Authentication.find_valid_by_id database_label + >|+ (fun (_, user) -> Authentication.Id.of_string auth_id, user) + >>= (fun (auth_id, user) -> handle_auth auth_id user) + >|- fun _ -> ()) + >|> function + | Ok ok -> Lwt_result.return ok + | Error () -> + HttpUtils.redirect_to_with_actions + root_login_path + [ Message.set + ~warning:[ Warning.Warning "Your session has expired, please sign in again" ] + ] + |> Lwt_result.ok in Response.handle ~src req result ;; -let confirmation_post req = +let login_verify_post req = let open Response in let tags = Pool_context.Logger.Tags.req req in - let result { Pool_context.database_label; user; _ } = - let handle_events = Pool_event.handle_events database_label user in - let* user, auth, token = - Helpers_login.decode_2fa_confirmation database_label req ~tags - |> bad_request_on_error login_get - in - let* user, events = - Helpers_login.confirm_2fa_login ~tags user auth token req - |> bad_request_on_error login_token_confirmation - in - let success () = + let result context = + Helpers_login.verify_2fa_login ~tags context req + >|> function + | Helpers_login.Verified user -> HttpUtils.redirect_to_with_actions root_entrypoint_path [ Sihl.Web.Session.set [ "user_id", user.Pool_user.id |> Pool_user.Id.value ] ] - in - events |> handle_events >|> success |> Lwt_result.ok + |> Lwt_result.ok + | Helpers_login.SessionExpired -> + HttpUtils.redirect_to_with_actions + root_login_path + [ Message.set + ~warning:[ Warning.Warning "Your session has expired, please sign in again" ] + ] + |> Lwt_result.ok + | Helpers_login.InvalidToken err -> + Lwt_result.fail err |> bad_request_on_error login_verify_get in - handle ~src req result + Response.handle ~src req result ;; let request_reset_password_get req = diff --git a/pool/web/view/page/page_public.ml b/pool/web/view/page/page_public.ml index 969fdda85..ae1b1b0e8 100644 --- a/pool/web/view/page/page_public.ml +++ b/pool/web/view/page/page_public.ml @@ -55,11 +55,7 @@ let login_form ;; let login_token_confirmation ?intended ?authentication_id context = - Page_login.login_token_confirmation - ?authentication_id - ?intended - context - "/login-confirmation" + Page_login.login_token_confirmation ?authentication_id ?intended context "/login/verify" ;; let index diff --git a/pool/web/view/page/page_root_login.ml b/pool/web/view/page/page_root_login.ml index a38144e42..cf64eb458 100644 --- a/pool/web/view/page/page_root_login.ml +++ b/pool/web/view/page/page_root_login.ml @@ -45,7 +45,7 @@ let token_confirmation ?authentication_id ?intended ~email context = ?authentication_id ?intended ~email - "/root/login-confirmation" + "/root/login/verify" ;; let request_reset_password Pool_context.{ language; csrf; _ } = From 7d7ae1dcbc9fd51916dc9e25b05f43fc812e6d94 Mon Sep 17 00:00:00 2001 From: Yannick Koller Date: Tue, 7 Jul 2026 16:58:10 +0200 Subject: [PATCH 08/24] fix: redirect to verify 2fa page dropping query params --- pool/web/handler/public_login.ml | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/pool/web/handler/public_login.ml b/pool/web/handler/public_login.ml index 692eddaf6..1b4193599 100644 --- a/pool/web/handler/public_login.ml +++ b/pool/web/handler/public_login.ml @@ -44,13 +44,12 @@ let login_post req = let handle_events = Pool_event.handle_events database_label user in let success () = HttpUtils.redirect_to_with_actions - "/login/verify" + (HttpUtils.retain_url_params req "/login/verify" |> Uri.to_string) [ Sihl.Web.Session.set [ "auth_id", auth.Authentication.id |> Authentication.Id.value ] ] - |> Lwt_result.ok in - events |> handle_events >|> success + events |> handle_events >|> success |> Lwt_result.ok | Helpers_login.DirectLogin login_user -> let success_and_redirect context_user = let redirect = From 3ecf755abbe2603096112ae8a77be719984bd00e Mon Sep 17 00:00:00 2001 From: Yannick Koller Date: Tue, 7 Jul 2026 16:59:58 +0200 Subject: [PATCH 09/24] fix: resend 2fa token not reading auth_id from session --- pool/web/handler/public_login.ml | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/pool/web/handler/public_login.ml b/pool/web/handler/public_login.ml index 1b4193599..eb70859ac 100644 --- a/pool/web/handler/public_login.ml +++ b/pool/web/handler/public_login.ml @@ -210,12 +210,9 @@ let resend_login_confirmation_token req = let handle_request ({ Pool_context.database_label; user; _ } as context) = let%lwt result = let* auth_id = - let%lwt urlencoded = Sihl.Web.Request.to_urlencoded req in - CCList.assoc_opt ~eq:CCString.equal Pool_message.Field.(show Id) urlencoded - |> CCFun.flip CCOption.bind CCList.head_opt - |> CCOption.map Authentication.Id.of_string - |> CCOption.to_result Pool_message.(Error.Invalid Field.Id) - |> Lwt.return + match Sihl.Web.Session.find "auth_id" req with + | None -> Lwt.return_error Pool_message.(Error.Invalid Field.Id) + | Some auth_id -> Authentication.Id.of_string auth_id |> Lwt.return_ok in let* (_ : Authentication.t), login_user = Authentication.find_valid_by_id database_label auth_id From dc56d7dd593a26908ca8c97bd246d45fef7cd349 Mon Sep 17 00:00:00 2001 From: Yannick Koller Date: Tue, 7 Jul 2026 17:05:44 +0200 Subject: [PATCH 10/24] chore: improve pool_authentication token validity migration --- .../migrations/migration_202607031200.ml | 19 +++++++++++++++---- 1 file changed, 15 insertions(+), 4 deletions(-) diff --git a/pool/app/pool_database/migrations/migration_202607031200.ml b/pool/app/pool_database/migrations/migration_202607031200.ml index beefb7d54..aef798d23 100644 --- a/pool/app/pool_database/migrations/migration_202607031200.ml +++ b/pool/app/pool_database/migrations/migration_202607031200.ml @@ -1,14 +1,25 @@ +let remove_automagic_timestamp_on_update_trigger = + Database.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_usage_count_to_authentication = Database.Migration.Step.create ~label:"add usage_count to pool_authentication" {sql| ALTER TABLE pool_authentication - MODIFY COLUMN valid_until TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP(), - ADD COLUMN usage_count TINYINT UNSIGNED NOT NULL AFTER token + ADD COLUMN usage_count TINYINT UNSIGNED NOT NULL DEFAULT 0 AFTER token |sql} ;; -(* This migration is executed on root and tenant databases *) let migration () = - Database.Migration.(empty "202607031200" |> add_step add_usage_count_to_authentication) + Database.Migration.( + empty "202607031200" + |> add_step remove_automagic_timestamp_on_update_trigger + |> add_step add_usage_count_to_authentication) ;; From f91bef12fc970e0aa729cc8a7fb7ba855229b9b4 Mon Sep 17 00:00:00 2001 From: Yannick Koller Date: Tue, 7 Jul 2026 17:10:56 +0200 Subject: [PATCH 11/24] chore: look in both pool_queue and pool_queue_jobs_history tables for last sent auth token --- pool/pool_queue/repo.ml | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) diff --git a/pool/pool_queue/repo.ml b/pool/pool_queue/repo.ml index b22cf7b61..020c24072 100644 --- a/pool/pool_queue/repo.ml +++ b/pool/pool_queue/repo.ml @@ -366,11 +366,15 @@ let find_last_login_token_sent_at_request = let auth_uuid_fragment = Pool_common.Id.sql_value_fragment "?" in [%string {sql| - SELECT persisted_at - FROM pool_queue_jobs_history - JOIN pool_queue_job_authentication ON queue_uuid = uuid - WHERE authentication_uuid = %{auth_uuid_fragment} - ORDER BY persisted_at DESC + SELECT J.persisted_at + FROM ( + SELECT uuid, persisted_at FROM pool_queue_jobs + UNION ALL + SELECT uuid, persisted_at FROM pool_queue_jobs_history + ) AS J + JOIN pool_queue_job_authentication A ON A.queue_uuid = J.uuid + WHERE A.authentication_uuid = %{auth_uuid_fragment} + ORDER BY J.persisted_at DESC LIMIT 1 |sql}] |> Pool_common.Repo.Id.t ->? Caqti_type.ptime From 768434f94e35cd5f620d5d147f2b5f742c08e71b Mon Sep 17 00:00:00 2001 From: Yannick Koller Date: Mon, 13 Jul 2026 11:00:17 +0200 Subject: [PATCH 12/24] fix: login not possible after auth session expiration --- pool/app/authentication/authentication.mli | 2 +- pool/app/authentication/event.ml | 2 +- pool/app/authentication/repo.ml | 2 +- pool/cqrs_command/login_command.ml | 2 +- .../authentication/authentication_test.ml | 2 +- pool/web/handler/helpers_login.ml | 14 +++++----- pool/web/handler/public_login.ml | 18 ++++++++++--- pool/web/handler/root_login.ml | 27 +++++++++++++------ 8 files changed, 47 insertions(+), 22 deletions(-) diff --git a/pool/app/authentication/authentication.mli b/pool/app/authentication/authentication.mli index c4a9b66e5..92897f47d 100644 --- a/pool/app/authentication/authentication.mli +++ b/pool/app/authentication/authentication.mli @@ -54,7 +54,7 @@ val create type event = | Created of t - | Deleted of t + | Deleted of Id.t | IncreaseUsageCount of t | ResetExpired diff --git a/pool/app/authentication/event.ml b/pool/app/authentication/event.ml index f52ba23cf..2893a7398 100644 --- a/pool/app/authentication/event.ml +++ b/pool/app/authentication/event.ml @@ -2,7 +2,7 @@ open Entity type event = | Created of t - | Deleted of t + | Deleted of Id.t | IncreaseUsageCount of t | ResetExpired [@@deriving eq, show] diff --git a/pool/app/authentication/repo.ml b/pool/app/authentication/repo.ml index bf668c8a8..ffae239c2 100644 --- a/pool/app/authentication/repo.ml +++ b/pool/app/authentication/repo.ml @@ -89,7 +89,7 @@ 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_usage_count_request = {sql| diff --git a/pool/cqrs_command/login_command.ml b/pool/cqrs_command/login_command.ml index abe6bc73e..43f468a4a 100644 --- a/pool/cqrs_command/login_command.ml +++ b/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 ] ;; diff --git a/pool/test/authentication/authentication_test.ml b/pool/test/authentication/authentication_test.ml index 622e0d6e7..0cc5536b1 100644 --- a/pool/test/authentication/authentication_test.ml +++ b/pool/test/authentication/authentication_test.ml @@ -172,7 +172,7 @@ let confirm_2fa_test _ () = (* Successful login *) let%lwt auth, user = find_valid_by_id pool auth_id ||> get_or_failwith in let events = - [ Deleted auth |> Pool_event.authentication + [ Deleted auth.id |> Pool_event.authentication ; ResetExpired |> Pool_event.authentication ] in diff --git a/pool/web/handler/helpers_login.ml b/pool/web/handler/helpers_login.ml index e0bc609f1..902804e8b 100644 --- a/pool/web/handler/helpers_login.ml +++ b/pool/web/handler/helpers_login.ml @@ -287,16 +287,18 @@ let increment_failed_login_attempt ~tags database_label email = type verify_outcome = | Verified of Pool_user.t | InvalidToken of Pool_message.Error.t - | SessionExpired + | SessionExpired of Authentication.Id.t + | SessionMissing let verify_2fa_login ~tags { Pool_context.database_label; user = context_user; _ } req = match Sihl.Web.Session.find "auth_id" req with - | None -> Lwt.return SessionExpired - | Some auth_id -> - Authentication.Id.of_string auth_id + | None -> Lwt.return SessionMissing + | Some id -> + let auth_id = Authentication.Id.of_string id in + auth_id |> Authentication.find_valid_by_id database_label >|> (function - | Error _ -> Lwt.return SessionExpired + | Error _ -> Lwt.return (SessionExpired auth_id) | Ok (auth, user) -> let%lwt urlencoded = Sihl.Web.Request.to_urlencoded req in (match Cqrs_command.Login_command.Confirm2FaLogin.decode urlencoded with @@ -327,6 +329,6 @@ let verify_2fa_login ~tags { Pool_context.database_label; user = context_user; _ database_label (Pool_user.email user) in - Lwt.return SessionExpired) + Lwt.return (SessionExpired auth_id)) else Lwt.return (InvalidToken err)))) ;; diff --git a/pool/web/handler/public_login.ml b/pool/web/handler/public_login.ml index eb70859ac..4c7c8b751 100644 --- a/pool/web/handler/public_login.ml +++ b/pool/web/handler/public_login.ml @@ -97,7 +97,10 @@ let login_verify_get req = let _ = Pool_common.Utils.with_log_error ~tags - (Pool_message.Error.Authorization "Failed to authenticate user") + (Pool_message.Error.Authorization + (Format.asprintf + "Failed to authenticate user: no valid authentication found for id %s" + auth_id)) in ()) >|> function @@ -121,7 +124,7 @@ let login_verify_post req = let open Response in let open HttpUtils in let tags = Pool_context.Logger.Tags.req req in - let handle_request ({ Pool_context.database_label; query_parameters; _ } as context) = + let handle_request (Pool_context.{ database_label; query_parameters; _ } as context) = let session_expired () = redirect_to_with_actions "/login" @@ -199,7 +202,16 @@ let login_verify_post req = "/login/verify" [ Message.set ~error:[ Pool_message.(Error.Invalid Field.OTP) ] ] |> Lwt_result.ok - | Helpers_login.SessionExpired -> session_expired () + | Helpers_login.SessionExpired auth_id -> + let%lwt () = + Pool_event.handle_event + ~tags + database_label + context.Pool_context.user + Pool_event.(Authentication (Authentication.Deleted auth_id)) + in + session_expired () + | Helpers_login.SessionMissing -> session_expired () in Response.handle ~src req handle_request ;; diff --git a/pool/web/handler/root_login.ml b/pool/web/handler/root_login.ml index 34a2c46ed..d1f9b0cb8 100644 --- a/pool/web/handler/root_login.ml +++ b/pool/web/handler/root_login.ml @@ -85,7 +85,15 @@ let login_verify_get req = let login_verify_post req = let open Response in let tags = Pool_context.Logger.Tags.req req in - let result context = + let result (Pool_context.{ database_label; _ } as context) = + let handle_session_error () = + HttpUtils.redirect_to_with_actions + root_login_path + [ Message.set + ~warning:[ Warning.Warning "Your session has expired, please sign in again" ] + ] + |> Lwt_result.ok + in Helpers_login.verify_2fa_login ~tags context req >|> function | Helpers_login.Verified user -> @@ -93,15 +101,18 @@ let login_verify_post req = root_entrypoint_path [ Sihl.Web.Session.set [ "user_id", user.Pool_user.id |> Pool_user.Id.value ] ] |> Lwt_result.ok - | Helpers_login.SessionExpired -> - HttpUtils.redirect_to_with_actions - root_login_path - [ Message.set - ~warning:[ Warning.Warning "Your session has expired, please sign in again" ] - ] - |> Lwt_result.ok | Helpers_login.InvalidToken err -> Lwt_result.fail err |> bad_request_on_error login_verify_get + | Helpers_login.SessionExpired auth_id -> + let%lwt () = + Pool_event.handle_event + ~tags + database_label + context.Pool_context.user + Pool_event.(Authentication (Authentication.Deleted auth_id)) + in + handle_session_error () + | Helpers_login.SessionMissing -> handle_session_error () in Response.handle ~src req result ;; From 5194a5214bc5667f12df8b24c918624a4437055c Mon Sep 17 00:00:00 2001 From: Yannick Koller Date: Tue, 14 Jul 2026 10:50:15 +0200 Subject: [PATCH 13/24] feat: introduce new 2FA flow on root tenant - extract common login flow into helpers_login.ml --- pool/routes/routes.ml | 5 +- pool/web/handler/helpers_login.ml | 116 ++++++++++++- pool/web/handler/helpers_login.mli | 89 ++++++++++ pool/web/handler/public_login.ml | 251 +++++++++-------------------- pool/web/handler/root_login.ml | 70 +++----- pool/web/view/page/page_login.ml | 2 +- 6 files changed, 304 insertions(+), 229 deletions(-) create mode 100644 pool/web/handler/helpers_login.mli diff --git a/pool/routes/routes.ml b/pool/routes/routes.ml index 6283662ee..331180df8 100644 --- a/pool/routes/routes.ml +++ b/pool/routes/routes.ml @@ -111,9 +111,7 @@ module Public = struct ; post "/login" Login.login_post ; get "/login/verify" Login.login_verify_get ; post "/login/verify" Login.login_verify_post - ; post - "/resend-login-confirmation-token" - Login.resend_login_confirmation_token + ; post "/login/verify/resend-token" Login.resend_token ; get "/request-reset-password" Login.request_reset_password_get ; post "/request-reset-password" Login.request_reset_password_post ; get "/reset-password" Login.reset_password_get @@ -998,6 +996,7 @@ module Root = struct ; post "/login" Login.login_post ; get "/login/verify" Login.login_verify_get ; post "/login/verify" Login.login_verify_post + ; post "/login/verify/resend-token" Login.resend_token ; get "/request-reset-password" Login.request_reset_password_get ; post "/request-reset-password" Login.request_reset_password_post ; get "/reset-password" Login.reset_password_get diff --git a/pool/web/handler/helpers_login.ml b/pool/web/handler/helpers_login.ml index 902804e8b..54ccf8fd2 100644 --- a/pool/web/handler/helpers_login.ml +++ b/pool/web/handler/helpers_login.ml @@ -1,9 +1,10 @@ open CCFun.Infix open Utils.Lwt_result.Infix open Pool_message -module Label = Database.Label module EmailAddress = Pool_user.EmailAddress module Password = Pool_user.Password +module Response = Http_response +module HttpUtils = Http_utils let src = Logs.Src.create "login helper" @@ -332,3 +333,116 @@ let verify_2fa_login ~tags { Pool_context.database_label; user = context_user; _ Lwt.return (SessionExpired auth_id)) else Lwt.return (InvalidToken err)))) ;; + +let login_verify_get ~render_confirmation ~login_path req = + let open HttpUtils in + let tags = Pool_context.Logger.Tags.req req in + let handle_request (Pool_context.{ database_label; _ } as context) = + let%lwt auth_data = + match Sihl.Web.Session.find "auth_id" req with + | Some auth_id -> + Authentication.Id.of_string auth_id + |> Authentication.find_valid_by_id database_label + >|- fun _ -> + let _ = + Pool_common.Utils.with_log_error + ~tags + (Pool_message.Error.Authorization + (Format.asprintf + "Failed to authenticate user: no valid authentication found for id %s" + auth_id)) + in + () + | None -> Lwt_result.fail () + in + match auth_data with + | Ok (auth, user) -> render_confirmation context auth user + | Error () -> + Http_utils.redirect_to_with_actions + login_path + [ Sihl.Web.Session.update_or_set_value ~key:"auth_id" (fun _ -> None) req + ; Message.set + ~warning: + [ Pool_message.Warning.Warning + "Your session has expired, please sign in again" + ] + ] + |> Lwt_result.ok + in + Http_response.handle ~src req handle_request +;; + +let login_verify_post ~verify_path ~handle_verified ~handle_invalid_session req = + let open HttpUtils in + let tags = Pool_context.Logger.Tags.req req in + let handle_request (Pool_context.{ database_label; _ } as context) = + match%lwt verify_2fa_login ~tags context req with + | Verified user -> handle_verified context user + | InvalidToken _ -> + HttpUtils.redirect_to_with_actions + verify_path + [ Message.set ~error:[ Pool_message.(Error.Invalid Field.OTP) ] ] + |> Lwt_result.ok + | SessionExpired auth_id -> + let%lwt () = + Pool_event.handle_event + ~tags + database_label + context.Pool_context.user + Pool_event.(Authentication (Authentication.Deleted auth_id)) + in + handle_invalid_session () + | SessionMissing -> handle_invalid_session () + in + Response.handle ~src req handle_request +;; + +let resend_token_post ~verify_path req = + let open HttpUtils in + let tags = Pool_context.Logger.Tags.req req in + let cooldown_seconds = 60 in + let handle_request (Pool_context.{ database_label; user; _ } as context) = + let%lwt result = + let* auth_id = + match Sihl.Web.Session.find "auth_id" req with + | None -> Lwt.return_error Pool_message.(Error.Invalid Field.Id) + | Some auth_id -> Authentication.Id.of_string auth_id |> Lwt.return_ok + in + let* (_ : Authentication.t), login_user = + Authentication.find_valid_by_id database_label auth_id + in + let* () = + let%lwt last_sent_at = + Pool_queue.find_last_login_token_sent_at + database_label + (Pool_common.Id.of_string (Authentication.Id.value auth_id)) + in + (match last_sent_at with + | None -> Ok () + | Some sent_at -> + let elapsed = + Ptime.diff (Ptime_clock.now ()) sent_at + |> Ptime.Span.to_float_s + |> int_of_float + in + if elapsed < cooldown_seconds + then Error Pool_message.Error.TokenAlreadySentRecently + else Ok ()) + |> Lwt_result.lift + in + let* _, (_ : Authentication.t), events = + create_2fa_auth ~id:auth_id ~tags req context login_user + in + let%lwt () = Pool_event.handle_events database_label user events in + Lwt.return_ok () + in + Http_response.Htmx.redirect + verify_path + ~actions: + (match result with + | Ok _ -> [ Message.set ~success:[ Pool_message.(Success.Resent Field.OTP) ] ] + | Error e -> [ Message.set ~error:[ e ] ]) + |> Lwt_result.ok + in + Response.handle ~src req handle_request +;; diff --git a/pool/web/handler/helpers_login.mli b/pool/web/handler/helpers_login.mli new file mode 100644 index 000000000..2d0c2ee4e --- /dev/null +++ b/pool/web/handler/helpers_login.mli @@ -0,0 +1,89 @@ +type login_step = + | MfaRequired of Pool_user.t * Authentication.t * Pool_event.t list + | DirectLogin of Pool_user.t + +(** [initiate_login req context urlencoded] validates the submitted credentials + and decides, based on the SMTP configuration and the user type/permissions, + whether the login has to continue with a 2FA step ([MfaRequired]) or can log + the user in directly ([DirectLogin]). *) +val initiate_login + : ?id:Authentication.Id.t + -> ?token:Authentication.Token.t + -> ?tags:Logs.Tag.set + -> Rock.Request.t + -> Pool_context.t + -> (string * string list) list + -> (login_step, Pool_message.Error.t) Lwt_result.t + +(** [create_2fa_login req context urlencoded] validates the submitted credentials + and unconditionally creates a 2FA authentication with the corresponding email + job events. Used by entry points that always require a second factor (root). *) +val create_2fa_login + : ?id:Authentication.Id.t + -> ?token:Authentication.Token.t + -> ?tags:Logs.Tag.set + -> Rock.Request.t + -> Pool_context.t + -> (string * string list) list + -> ( Pool_user.t * Authentication.t * Pool_event.t list + , Pool_message.Error.t ) + Lwt_result.t + +(** [decode_2fa_confirmation database_label req ~tags] decodes the submitted + authentication id and token and looks up the corresponding (still valid) + authentication and user. *) +val decode_2fa_confirmation + : Database.Label.t + -> Rock.Request.t + -> tags:Logs.Tag.set + -> ( Pool_user.t * Authentication.t * Authentication.Token.t + , Pool_message.Error.t ) + Lwt_result.t + +(** [confirm_2fa_login ~tags user authentication token req] confirms the 2FA [token] + for [authentication] and returns the resulting login events. *) +val confirm_2fa_login + : tags:Logs.Tag.set + -> Pool_user.t + -> Authentication.t + -> Authentication.Token.t + -> Rock.Request.t + -> (Pool_user.t * Pool_event.t list, Pool_message.Error.t) Lwt_result.t + +(** [login_verify_get ~render_confirmation ~login_path req] renders the 2FA token + confirmation page for the authentication stored in the session. + + [render_confirmation context auth user] produces the response + A missing/expired authentication redirects to [login_path]. *) +val login_verify_get + : render_confirmation: + (Pool_context.t + -> Authentication.t + -> Pool_user.t + -> (Rock.Response.t, Http_response.http_error) Lwt_result.t) + -> login_path:string + -> Rock.Request.t + -> Rock.Response.t Lwt.t + +(** [login_verify_post ~verify_path ~handle_verified ~handle_invalid_session req] + confirms the submitted 2FA token. + + On success [handle_verified context user] is called. + + An invalid token redirects back to [verify_path]. + + A missing/expired session is delegated to [handle_invalid_session]. *) +val login_verify_post + : verify_path:string + -> handle_verified: + (Pool_context.t + -> Pool_user.t + -> (Rock.Response.t, Http_response.http_error) Lwt_result.t) + -> handle_invalid_session: + (unit -> (Rock.Response.t, Http_response.http_error) Lwt_result.t) + -> Rock.Request.t + -> Rock.Response.t Lwt.t + +(** [resend_token_post ~verify_path req] re-issues the 2FA token for the pending and + redirects to [verify_path]. *) +val resend_token_post : verify_path:string -> Rock.Request.t -> Rock.Response.t Lwt.t diff --git a/pool/web/handler/public_login.ml b/pool/web/handler/public_login.ml index 4c7c8b751..3d30df2bf 100644 --- a/pool/web/handler/public_login.ml +++ b/pool/web/handler/public_login.ml @@ -75,196 +75,103 @@ let login_post req = ;; let login_verify_get req = - let tags = Pool_context.Logger.Tags.req req in - let handle_request (Pool_context.{ database_label; _ } as context) = - let handle_auth auth_id user = - Page.Public.login_token_confirmation - ~authentication_id:auth_id - ?intended:(HttpUtils.find_intended_opt req) - ~email:(Pool_user.email user) - context - >|> create_layout req ~active_navigation:"/login" context - >|+ Sihl.Web.Response.of_html - in - (match Sihl.Web.Session.find "auth_id" req with - | None -> Lwt_result.fail () - | Some auth_id -> - Authentication.Id.of_string auth_id - |> Authentication.find_valid_by_id database_label - >|+ (fun (_, user) -> Authentication.Id.of_string auth_id, user) - >>= (fun (auth_id, user) -> handle_auth auth_id user) - >|- fun _ -> - let _ = - Pool_common.Utils.with_log_error - ~tags - (Pool_message.Error.Authorization - (Format.asprintf - "Failed to authenticate user: no valid authentication found for id %s" - auth_id)) - in - ()) - >|> function - | Ok ok -> Lwt_result.return ok - | Error () -> - HttpUtils.redirect_to_with_actions - "/login" - [ Sihl.Web.Session.update_or_set_value ~key:"auth_id" (fun _ -> None) req - ; Message.set - ~warning: - [ Pool_message.Warning.Warning - "Your session has expired, please sign in again" - ] - ] - |> Lwt_result.ok - in - Response.handle ~src req handle_request + Helpers_login.login_verify_get + ~login_path:"/login" + ~render_confirmation:(fun context auth user -> + Response.bad_request_render_error context + @@ (Page.Public.login_token_confirmation + ~authentication_id:auth.Authentication.id + ?intended:(HttpUtils.find_intended_opt req) + ~email:(Pool_user.email user) + context + >|> create_layout req ~active_navigation:"/login" context + >|+ Sihl.Web.Response.of_html)) + req ;; let login_verify_post req = let open Response in let open HttpUtils in let tags = Pool_context.Logger.Tags.req req in - let handle_request (Pool_context.{ database_label; query_parameters; _ } as context) = - let session_expired () = + let login Pool_context.{ database_label; query_parameters; _ } user = + let success_and_redirect + ?(set_completion_cookie = false) + ?redirect + ?(actions = []) + context_user + = + let redirect = + let open CCOption in + redirect + <+> find_intended_opt req + |> value ~default:(Pool_context.dashboard_path context_user) + |> url_with_field_params query_parameters + in + let* () = increase_sign_in_count ~tags database_label context_user in redirect_to_with_actions - "/login" - [ Message.set - ~warning: - [ Pool_message.Warning.Warning - "Your session has expired, please sign in again" - ] - ] + redirect + ([ Sihl.Web.Session.set [ "user_id", user.Pool_user.id |> Pool_user.Id.value ] ] + @ actions) + ||> (fun res -> + if set_completion_cookie + then + Sihl.Web.Session.set_value ~key:Contact.profile_completion_cookie "true" req res + else res) |> Lwt_result.ok in - let login user = - let success_and_redirect - ?(set_completion_cookie = false) - ?redirect - ?(actions = []) - context_user - = - let redirect = - let open CCOption in - redirect - <+> find_intended_opt req - |> value ~default:(Pool_context.dashboard_path context_user) - |> url_with_field_params query_parameters - in - let* () = increase_sign_in_count ~tags database_label context_user in - redirect_to_with_actions - redirect - ([ Sihl.Web.Session.set [ "user_id", user.Pool_user.id |> Pool_user.Id.value ] ] - @ actions) - ||> (fun res -> - if set_completion_cookie - then - Sihl.Web.Session.set_value ~key:Contact.profile_completion_cookie "true" req res - else res) - |> Lwt_result.ok - in - let handle_admin_login user = - user.Pool_user.id - |> Admin.(Id.of_user %> find database_label) - >|+ Pool_context.admin - >>= success_and_redirect - in - let handle_contact_login user = - let* contact = user.Pool_user.id |> Contact.(Id.of_user %> find database_label) in - let%lwt required_answers_given = - Custom_field.all_required_answered database_label (Contact.id contact) - in - let contact = contact |> Pool_context.contact in - match required_answers_given with - | true -> success_and_redirect contact - | false -> - success_and_redirect - ~set_completion_cookie:true - ~redirect:"/user/completion" - ~actions:[ Message.set ~error:[ Pool_message.Error.RequiredFieldsMissing ] ] - contact + let handle_admin_login user = + user.Pool_user.id + |> Admin.(Id.of_user %> find database_label) + >|+ Pool_context.admin + >>= success_and_redirect + in + let handle_contact_login user = + let* contact = user.Pool_user.id |> Contact.(Id.of_user %> find database_label) in + let%lwt required_answers_given = + Custom_field.all_required_answered database_label (Contact.id contact) in - match user |> Pool_user.is_confirmed with + let contact = contact |> Pool_context.contact in + match required_answers_given with + | true -> success_and_redirect contact | false -> - redirect_to (url_with_field_params query_parameters "/email-confirmation") - |> Lwt_result.ok - | true -> - user - |> Admin.user_is_admin database_label - >|> (function - | true -> handle_admin_login user - | false -> handle_contact_login user) + success_and_redirect + ~set_completion_cookie:true + ~redirect:"/user/completion" + ~actions:[ Message.set ~error:[ Pool_message.Error.RequiredFieldsMissing ] ] + contact in - Helpers_login.verify_2fa_login ~tags context req - >|> function - | Helpers_login.Verified user -> bad_request_on_error login_verify_get @@ login user - | Helpers_login.InvalidToken _ -> - HttpUtils.redirect_to_with_actions - "/login/verify" - [ Message.set ~error:[ Pool_message.(Error.Invalid Field.OTP) ] ] + match user |> Pool_user.is_confirmed with + | false -> + redirect_to (url_with_field_params query_parameters "/email-confirmation") |> Lwt_result.ok - | Helpers_login.SessionExpired auth_id -> - let%lwt () = - Pool_event.handle_event - ~tags - database_label - context.Pool_context.user - Pool_event.(Authentication (Authentication.Deleted auth_id)) - in - session_expired () - | Helpers_login.SessionMissing -> session_expired () + | true -> + user + |> Admin.user_is_admin database_label + >|> (function + | true -> handle_admin_login user + | false -> handle_contact_login user) in - Response.handle ~src req handle_request -;; - -let resend_login_confirmation_token req = - let tags = Pool_context.Logger.Tags.req req in - let cooldown_seconds = 60 in - let handle_request ({ Pool_context.database_label; user; _ } as context) = - let%lwt result = - let* auth_id = - match Sihl.Web.Session.find "auth_id" req with - | None -> Lwt.return_error Pool_message.(Error.Invalid Field.Id) - | Some auth_id -> Authentication.Id.of_string auth_id |> Lwt.return_ok - in - let* (_ : Authentication.t), login_user = - Authentication.find_valid_by_id database_label auth_id - in - let* () = - let%lwt last_sent_at = - Pool_queue.find_last_login_token_sent_at - database_label - (Pool_common.Id.of_string (Authentication.Id.value auth_id)) - in - (match last_sent_at with - | None -> Ok () - | Some sent_at -> - let elapsed = - Ptime.diff (Ptime_clock.now ()) sent_at - |> Ptime.Span.to_float_s - |> int_of_float - in - if elapsed < cooldown_seconds - then Error Pool_message.Error.TokenAlreadySentRecently - else Ok ()) - |> Lwt_result.lift - in - let* _, (_ : Authentication.t), events = - Helpers_login.create_2fa_auth ~id:auth_id ~tags req context login_user - in - let%lwt () = Pool_event.handle_events database_label user events in - Lwt.return_ok () - in - Http_response.Htmx.redirect - "/login/verify" - ~actions: - (match result with - | Ok _ -> [ Message.set ~success:[ Pool_message.(Success.Resent Field.OTP) ] ] - | Error e -> [ Message.set ~error:[ e ] ]) + let session_expired () = + redirect_to_with_actions + "/login" + [ Message.set + ~warning: + [ Pool_message.Warning.Warning + "Your session has expired, please sign in again" + ] + ] |> Lwt_result.ok in - Response.handle ~src req handle_request + Helpers_login.login_verify_post + ~verify_path:"/login/verify" + ~handle_verified:(fun context user -> + bad_request_on_error login_verify_get @@ login context user) + ~handle_invalid_session:session_expired + req ;; +let resend_token = Helpers_login.resend_token_post ~verify_path:"/login/verify" + let request_reset_password_get req = let result context = Response.bad_request_render_error context diff --git a/pool/web/handler/root_login.ml b/pool/web/handler/root_login.ml index d1f9b0cb8..9c8bb0e18 100644 --- a/pool/web/handler/root_login.ml +++ b/pool/web/handler/root_login.ml @@ -50,73 +50,39 @@ let login_post req = ;; let login_verify_get req = - let result (Pool_context.{ database_label; _ } as context) = - let handle_auth auth_id user = + Helpers_login.login_verify_get + ~login_path:root_login_path + ~render_confirmation:(fun context auth user -> Page.Root.Login.token_confirmation - ~authentication_id:auth_id + ~authentication_id:auth.Authentication.id ?intended:(HttpUtils.find_intended_opt req) ~email:(Pool_user.email user) context >|> General.create_root_layout ~active_navigation:"/root/login" context ||> Sihl.Web.Response.of_html - |> Lwt_result.ok - in - (match Sihl.Web.Session.find "auth_id" req with - | None -> Lwt_result.fail () - | Some auth_id -> - Authentication.Id.of_string auth_id - |> Authentication.find_valid_by_id database_label - >|+ (fun (_, user) -> Authentication.Id.of_string auth_id, user) - >>= (fun (auth_id, user) -> handle_auth auth_id user) - >|- fun _ -> ()) - >|> function - | Ok ok -> Lwt_result.return ok - | Error () -> - HttpUtils.redirect_to_with_actions - root_login_path - [ Message.set - ~warning:[ Warning.Warning "Your session has expired, please sign in again" ] - ] - |> Lwt_result.ok - in - Response.handle ~src req result + |> Lwt_result.ok) + req ;; -let login_verify_post req = - let open Response in - let tags = Pool_context.Logger.Tags.req req in - let result (Pool_context.{ database_label; _ } as context) = - let handle_session_error () = +let login_verify_post = + Helpers_login.login_verify_post + ~verify_path:root_login_verify_path + ~handle_verified:(fun _ user -> + HttpUtils.redirect_to_with_actions + root_entrypoint_path + [ Sihl.Web.Session.set [ "user_id", user.Pool_user.id |> Pool_user.Id.value ] ] + |> Lwt_result.ok) + ~handle_invalid_session:(fun () -> HttpUtils.redirect_to_with_actions root_login_path [ Message.set ~warning:[ Warning.Warning "Your session has expired, please sign in again" ] ] - |> Lwt_result.ok - in - Helpers_login.verify_2fa_login ~tags context req - >|> function - | Helpers_login.Verified user -> - HttpUtils.redirect_to_with_actions - root_entrypoint_path - [ Sihl.Web.Session.set [ "user_id", user.Pool_user.id |> Pool_user.Id.value ] ] - |> Lwt_result.ok - | Helpers_login.InvalidToken err -> - Lwt_result.fail err |> bad_request_on_error login_verify_get - | Helpers_login.SessionExpired auth_id -> - let%lwt () = - Pool_event.handle_event - ~tags - database_label - context.Pool_context.user - Pool_event.(Authentication (Authentication.Deleted auth_id)) - in - handle_session_error () - | Helpers_login.SessionMissing -> handle_session_error () - in - Response.handle ~src req result + |> Lwt_result.ok) ;; +let resend_token = Helpers_login.resend_token_post ~verify_path:root_login_verify_path + let request_reset_password_get req = let result context = Response.bad_request_render_error context diff --git a/pool/web/view/page/page_login.ml b/pool/web/view/page/page_login.ml index 6b4e19cfd..1695090ae 100644 --- a/pool/web/view/page/page_login.ml +++ b/pool/web/view/page/page_login.ml @@ -42,7 +42,7 @@ let login_token_confirmation let resend_action = HttpUtils.externalize_path_with_params query_parameters - "/resend-login-confirmation-token" + (Format.asprintf "%s/resend-token" url) in let button_id = "resend-token-button" in let countdown_id = "resend-token-countdown" in From c7edc5694cf4e5c5a1402b212a1c1bc04a799201 Mon Sep 17 00:00:00 2001 From: Yannick Koller Date: Tue, 14 Jul 2026 12:35:27 +0200 Subject: [PATCH 14/24] chore: cleanup db migrations --- .../migrations/migration_202606170000.ml | 21 --------- .../migrations/migration_202607031200.ml | 25 ----------- .../migrations/migration_202607141227.ml | 44 +++++++++++++++++++ pool/app/pool_database/root.ml | 4 +- pool/app/pool_database/tenant.ml | 4 +- 5 files changed, 46 insertions(+), 52 deletions(-) delete mode 100644 pool/app/pool_database/migrations/migration_202606170000.ml delete mode 100644 pool/app/pool_database/migrations/migration_202607031200.ml create mode 100644 pool/app/pool_database/migrations/migration_202607141227.ml diff --git a/pool/app/pool_database/migrations/migration_202606170000.ml b/pool/app/pool_database/migrations/migration_202606170000.ml deleted file mode 100644 index ac0754f6e..000000000 --- a/pool/app/pool_database/migrations/migration_202606170000.ml +++ /dev/null @@ -1,21 +0,0 @@ -let create_pool_queue_job_authentication_table = - Database.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), - 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} -;; - -(* This migration is executed on root and tenant databases *) -let migration () = - Database.Migration.( - empty "202606170000" |> add_step create_pool_queue_job_authentication_table) -;; diff --git a/pool/app/pool_database/migrations/migration_202607031200.ml b/pool/app/pool_database/migrations/migration_202607031200.ml deleted file mode 100644 index aef798d23..000000000 --- a/pool/app/pool_database/migrations/migration_202607031200.ml +++ /dev/null @@ -1,25 +0,0 @@ -let remove_automagic_timestamp_on_update_trigger = - Database.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_usage_count_to_authentication = - Database.Migration.Step.create - ~label:"add usage_count to pool_authentication" - {sql| - ALTER TABLE pool_authentication - ADD COLUMN usage_count TINYINT UNSIGNED NOT NULL DEFAULT 0 AFTER token - |sql} -;; - -let migration () = - Database.Migration.( - empty "202607031200" - |> add_step remove_automagic_timestamp_on_update_trigger - |> add_step add_usage_count_to_authentication) -;; diff --git a/pool/app/pool_database/migrations/migration_202607141227.ml b/pool/app/pool_database/migrations/migration_202607141227.ml new file mode 100644 index 000000000..3f058f2d6 --- /dev/null +++ b/pool/app/pool_database/migrations/migration_202607141227.ml @@ -0,0 +1,44 @@ +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), + 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_usage_count_to_authentication = + Migration.Step.create + ~label:"add usage_count to pool_authentication" + {sql| + ALTER TABLE pool_authentication + ADD COLUMN usage_count 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_usage_count_to_authentication) +;; diff --git a/pool/app/pool_database/root.ml b/pool/app/pool_database/root.ml index 66dbb59c3..9c3803c31 100644 --- a/pool/app/pool_database/root.ml +++ b/pool/app/pool_database/root.ml @@ -32,12 +32,10 @@ let steps = ; Migration_202505121331.migration () ; Migration_202506261422.migration () ; Migration_202603061300.migration () - ; Migration_202606170000.migration () - ; Migration_202607031200.migration () ; Migration_202607031400.migration () ; Migration_202607051000.migration () ; Migration_202607061500.migration_root () - ; Migration_202607031200.migration () + ; Migration_202607141227.migration () ] |> sort in diff --git a/pool/app/pool_database/tenant.ml b/pool/app/pool_database/tenant.ml index 29083da58..5989ee265 100644 --- a/pool/app/pool_database/tenant.ml +++ b/pool/app/pool_database/tenant.ml @@ -96,12 +96,10 @@ let steps = ; Migration_202604200000.migration () ; Migration_202605110000.migration () ; Migration_202605291200.migration () - ; Migration_202606170000.migration () - ; Migration_202607031200.migration () ; Migration_202607031400.migration () ; Migration_202607051000.migration () ; Migration_202607061500.migration () - ; Migration_202607031200.migration () + ; Migration_202607141227.migration () ] |> sort in From 8a1c63847a12ff8d3795995c10c8e770ea7a39a1 Mon Sep 17 00:00:00 2001 From: Yannick Koller Date: Tue, 14 Jul 2026 13:56:27 +0200 Subject: [PATCH 15/24] fix: explicitly specify resend 2fa code button type --- pool/web/view/page/page_login.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/pool/web/view/page/page_login.ml b/pool/web/view/page/page_login.ml index 1695090ae..8a33f0b0a 100644 --- a/pool/web/view/page/page_login.ml +++ b/pool/web/view/page/page_login.ml @@ -80,7 +80,8 @@ let login_token_confirmation ~a:[ a_class [ "flexrow"; "flex-gap-sm" ] ] ([ button ~a: - [ a_id button_id + [ a_button_type `Button + ; a_id button_id ; a_class [ "btn"; "primary"; "is-text" ] ; a_style "padding:0" ; Htmx.hx_post resend_action From 8e2ee158c0ed8523e702a5b89484d24bda5f624c Mon Sep 17 00:00:00 2001 From: Yannick Koller Date: Tue, 14 Jul 2026 14:15:01 +0200 Subject: [PATCH 16/24] chore: clear auth_id from session if it has expired --- pool/web/handler/helpers_login.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/pool/web/handler/helpers_login.ml b/pool/web/handler/helpers_login.ml index 54ccf8fd2..9fa80f9a9 100644 --- a/pool/web/handler/helpers_login.ml +++ b/pool/web/handler/helpers_login.ml @@ -392,6 +392,7 @@ let login_verify_post ~verify_path ~handle_verified ~handle_invalid_session req Pool_event.(Authentication (Authentication.Deleted auth_id)) in handle_invalid_session () + >|+ Sihl.Web.Session.update_or_set_value ~key:"auth_id" (fun _ -> None) req | SessionMissing -> handle_invalid_session () in Response.handle ~src req handle_request From c0a48c28cc8a1361cbfdf9abcac302060e45aa29 Mon Sep 17 00:00:00 2001 From: Yannick Koller Date: Tue, 14 Jul 2026 14:16:33 +0200 Subject: [PATCH 17/24] chore: add index on authentication_uuid column --- pool/app/pool_database/migrations/migration_202607141227.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/pool/app/pool_database/migrations/migration_202607141227.ml b/pool/app/pool_database/migrations/migration_202607141227.ml index 3f058f2d6..85ca34c82 100644 --- a/pool/app/pool_database/migrations/migration_202607141227.ml +++ b/pool/app/pool_database/migrations/migration_202607141227.ml @@ -11,6 +11,7 @@ let create_pool_queue_job_authentication_table = 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} From 4da3e063789d47eb80dca5a339e782d4eda1efdc Mon Sep 17 00:00:00 2001 From: Yannick Koller Date: Tue, 14 Jul 2026 14:30:20 +0200 Subject: [PATCH 18/24] chore: define authentication timeout in central space --- pool/app/authentication/entity.ml | 2 ++ pool/web/handler/helpers_login.ml | 2 +- pool/web/view/page/page_login.ml | 3 +-- 3 files changed, 4 insertions(+), 3 deletions(-) diff --git a/pool/app/authentication/entity.ml b/pool/app/authentication/entity.ml index fd26da13b..4db2576b6 100644 --- a/pool/app/authentication/entity.ml +++ b/pool/app/authentication/entity.ml @@ -56,3 +56,5 @@ type t = ; usage_count : UsageCount.t } [@@deriving eq, show { with_path = false }] + +let resend_cooldown_seconds = 60 diff --git a/pool/web/handler/helpers_login.ml b/pool/web/handler/helpers_login.ml index 9fa80f9a9..7e5a824be 100644 --- a/pool/web/handler/helpers_login.ml +++ b/pool/web/handler/helpers_login.ml @@ -426,7 +426,7 @@ let resend_token_post ~verify_path req = |> Ptime.Span.to_float_s |> int_of_float in - if elapsed < cooldown_seconds + if elapsed < Authentication.resend_cooldown_seconds then Error Pool_message.Error.TokenAlreadySentRecently else Ok ()) |> Lwt_result.lift diff --git a/pool/web/view/page/page_login.ml b/pool/web/view/page/page_login.ml index 8a33f0b0a..f255a807b 100644 --- a/pool/web/view/page/page_login.ml +++ b/pool/web/view/page/page_login.ml @@ -29,7 +29,6 @@ let login_token_confirmation | None -> txt "" in let resend_token sent_at = - let cooldown_seconds = 60 in let remaining_seconds = match sent_at with | None -> 0 @@ -37,7 +36,7 @@ let login_token_confirmation let elapsed = Ptime.diff (Ptime_clock.now ()) t |> Ptime.Span.to_float_s |> int_of_float in - max 0 (cooldown_seconds - elapsed) + max 0 (Authentication.resend_cooldown_seconds - elapsed) in let resend_action = HttpUtils.externalize_path_with_params From 601903b37438bd6d43ed2de990cbf20be34a6174 Mon Sep 17 00:00:00 2001 From: Yannick Koller Date: Tue, 14 Jul 2026 14:31:24 +0200 Subject: [PATCH 19/24] fix: rotation of authentication id when there already is an active authentication --- pool/app/authentication/authentication.ml | 1 + pool/app/authentication/authentication.mli | 4 ++++ pool/app/authentication/repo.ml | 16 ++++++++++++++++ pool/web/handler/helpers_login.ml | 6 +++++- 4 files changed, 26 insertions(+), 1 deletion(-) diff --git a/pool/app/authentication/authentication.ml b/pool/app/authentication/authentication.ml index f040a39dd..5f16df5f9 100644 --- a/pool/app/authentication/authentication.ml +++ b/pool/app/authentication/authentication.ml @@ -9,6 +9,7 @@ let create ?(id = Id.create ()) ?(token = Token.generate ()) ~user ~channel () = ;; 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 diff --git a/pool/app/authentication/authentication.mli b/pool/app/authentication/authentication.mli index 92897f47d..2f3c18c9c 100644 --- a/pool/app/authentication/authentication.mli +++ b/pool/app/authentication/authentication.mli @@ -40,6 +40,8 @@ type t = ; usage_count : UsageCount.t } +val resend_cooldown_seconds : int + val equal : t -> t -> bool val show : t -> string val pp : Format.formatter -> t -> unit @@ -68,5 +70,7 @@ 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 diff --git a/pool/app/authentication/repo.ml b/pool/app/authentication/repo.ml index ffae239c2..0bddc68fd 100644 --- a/pool/app/authentication/repo.ml +++ b/pool/app/authentication/repo.ml @@ -81,6 +81,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 diff --git a/pool/web/handler/helpers_login.ml b/pool/web/handler/helpers_login.ml index 7e5a824be..dbb380c14 100644 --- a/pool/web/handler/helpers_login.ml +++ b/pool/web/handler/helpers_login.ml @@ -147,6 +147,11 @@ let validate_login req ~tags database_label ~email ~password = (* Internal helper: create 2FA auth token and email job events for a validated user *) let create_2fa_auth ?id ?token ~tags req { Pool_context.database_label; language; _ } user = + let%lwt id = + match id with + | Some _ as id -> Lwt.return id + | None -> Authentication.find_id_by_user database_label (Pool_user.id user) + in let auth = Authentication.(create ?id ?token ~user ~channel:Channel.Email) () in let%lwt email_job = let open Message_template in @@ -401,7 +406,6 @@ let login_verify_post ~verify_path ~handle_verified ~handle_invalid_session req let resend_token_post ~verify_path req = let open HttpUtils in let tags = Pool_context.Logger.Tags.req req in - let cooldown_seconds = 60 in let handle_request (Pool_context.{ database_label; user; _ } as context) = let%lwt result = let* auth_id = From ce99b7a1d93ae71af98144583512bded84483bab Mon Sep 17 00:00:00 2001 From: Yannick Koller Date: Tue, 14 Jul 2026 14:39:27 +0200 Subject: [PATCH 20/24] chore: reformat authentication.mli --- pool/app/authentication/authentication.mli | 2 -- 1 file changed, 2 deletions(-) diff --git a/pool/app/authentication/authentication.mli b/pool/app/authentication/authentication.mli index 2f3c18c9c..b6d2bba7b 100644 --- a/pool/app/authentication/authentication.mli +++ b/pool/app/authentication/authentication.mli @@ -41,7 +41,6 @@ type t = } val resend_cooldown_seconds : int - val equal : t -> t -> bool val show : t -> string val pp : Format.formatter -> t -> unit @@ -71,6 +70,5 @@ val find_valid_by_id -> (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 From d53e2182ad254e9c2b0d46f9ccc1e53e373764f0 Mon Sep 17 00:00:00 2001 From: Yannick Koller Date: Tue, 14 Jul 2026 15:36:02 +0200 Subject: [PATCH 21/24] chore: use better aliases in last login token email query --- pool/pool_queue/repo.ml | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/pool/pool_queue/repo.ml b/pool/pool_queue/repo.ml index 020c24072..2abd2e631 100644 --- a/pool/pool_queue/repo.ml +++ b/pool/pool_queue/repo.ml @@ -366,15 +366,15 @@ let find_last_login_token_sent_at_request = let auth_uuid_fragment = Pool_common.Id.sql_value_fragment "?" in [%string {sql| - SELECT J.persisted_at + 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 J - JOIN pool_queue_job_authentication A ON A.queue_uuid = J.uuid - WHERE A.authentication_uuid = %{auth_uuid_fragment} - ORDER BY J.persisted_at DESC + ) 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 From 31f97d363f6593400cdc8397d17d81f2a78a1e71 Mon Sep 17 00:00:00 2001 From: Yannick Koller Date: Tue, 14 Jul 2026 15:39:13 +0200 Subject: [PATCH 22/24] chore: improve remaining 2fa token uses calculation --- pool/web/handler/helpers_login.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/pool/web/handler/helpers_login.ml b/pool/web/handler/helpers_login.ml index dbb380c14..e8b7a1cf6 100644 --- a/pool/web/handler/helpers_login.ml +++ b/pool/web/handler/helpers_login.ml @@ -323,8 +323,8 @@ let verify_2fa_login ~tags { Pool_context.database_label; user = context_user; _ [ Authentication.IncreaseUsageCount auth |> Pool_event.authentication ] in let remaining = - Authentication.UsageCount.(value limit) - - Authentication.UsageCount.value auth.Authentication.usage_count + Authentication.UsageCount.( + value limit - value auth.Authentication.usage_count) - 1 in if remaining <= 0 From 3185e3ac3e99eaf63afd93bc97d8da264bd8080d Mon Sep 17 00:00:00 2001 From: Yannick Koller Date: Tue, 14 Jul 2026 15:41:59 +0200 Subject: [PATCH 23/24] chore: add types to unused arguments --- pool/web/handler/helpers_login.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/pool/web/handler/helpers_login.ml b/pool/web/handler/helpers_login.ml index e8b7a1cf6..0eb1717e4 100644 --- a/pool/web/handler/helpers_login.ml +++ b/pool/web/handler/helpers_login.ml @@ -348,7 +348,7 @@ let login_verify_get ~render_confirmation ~login_path req = | Some auth_id -> Authentication.Id.of_string auth_id |> Authentication.find_valid_by_id database_label - >|- fun _ -> + >|- fun (_ : Error.t) -> let _ = Pool_common.Utils.with_log_error ~tags @@ -435,7 +435,7 @@ let resend_token_post ~verify_path req = else Ok ()) |> Lwt_result.lift in - let* _, (_ : Authentication.t), events = + let* (_ : Pool_user.t), (_ : Authentication.t), events = create_2fa_auth ~id:auth_id ~tags req context login_user in let%lwt () = Pool_event.handle_events database_label user events in From e1ef731e4ce10374cdcc3bee564b7bec1568f1f5 Mon Sep 17 00:00:00 2001 From: Yannick Koller Date: Tue, 14 Jul 2026 16:13:49 +0200 Subject: [PATCH 24/24] chore: rename usage_count to failed_attempts in pool authentication --- pool/app/authentication/authentication.ml | 7 +++- pool/app/authentication/authentication.mli | 6 ++-- pool/app/authentication/entity.ml | 4 +-- pool/app/authentication/event.ml | 4 +-- pool/app/authentication/repo.ml | 35 +++++++++++++------ .../migrations/migration_202607141227.ml | 8 ++--- pool/web/handler/helpers_login.ml | 7 ++-- 7 files changed, 45 insertions(+), 26 deletions(-) diff --git a/pool/app/authentication/authentication.ml b/pool/app/authentication/authentication.ml index 5f16df5f9..4317c03c0 100644 --- a/pool/app/authentication/authentication.ml +++ b/pool/app/authentication/authentication.ml @@ -5,7 +5,12 @@ 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; usage_count = UsageCount.of_int 0 } + { 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 diff --git a/pool/app/authentication/authentication.mli b/pool/app/authentication/authentication.mli index b6d2bba7b..95fdcf2c2 100644 --- a/pool/app/authentication/authentication.mli +++ b/pool/app/authentication/authentication.mli @@ -21,7 +21,7 @@ module Token : sig val schema : unit -> (Pool_conformist.error_msg, t) Pool_conformist.Field.t end -module UsageCount : sig +module FailedAttempts : sig type t val equal : t -> t -> bool @@ -37,7 +37,7 @@ type t = ; user_uuid : Pool_user.Id.t ; channel : Channel.t ; token : Token.t - ; usage_count : UsageCount.t + ; failed_attempts : FailedAttempts.t } val resend_cooldown_seconds : int @@ -56,7 +56,7 @@ val create type event = | Created of t | Deleted of Id.t - | IncreaseUsageCount of t + | IncreaseFailedAttempts of t | ResetExpired val equal_event : event -> event -> bool diff --git a/pool/app/authentication/entity.ml b/pool/app/authentication/entity.ml index 4db2576b6..18b86d40e 100644 --- a/pool/app/authentication/entity.ml +++ b/pool/app/authentication/entity.ml @@ -18,7 +18,7 @@ module Channel = struct include Core end -module UsageCount = struct +module FailedAttempts = struct include Pool_model.Base.Integer let limit = of_int 3 @@ -53,7 +53,7 @@ type t = ; user_uuid : Pool_user.Id.t ; channel : Channel.t ; token : Token.t - ; usage_count : UsageCount.t + ; failed_attempts : FailedAttempts.t } [@@deriving eq, show { with_path = false }] diff --git a/pool/app/authentication/event.ml b/pool/app/authentication/event.ml index 2893a7398..533024d8a 100644 --- a/pool/app/authentication/event.ml +++ b/pool/app/authentication/event.ml @@ -3,13 +3,13 @@ open Entity type event = | Created of t | Deleted of Id.t - | IncreaseUsageCount of 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 - | IncreaseUsageCount t -> Repo.increase_usage_count pool t + | IncreaseFailedAttempts t -> Repo.increase_failed_attempts pool t | ResetExpired -> Repo.reset_expired pool () ;; diff --git a/pool/app/authentication/repo.ml b/pool/app/authentication/repo.ml index 0bddc68fd..7184f057d 100644 --- a/pool/app/authentication/repo.ml +++ b/pool/app/authentication/repo.ml @@ -7,11 +7,24 @@ module Repo_entity = struct module Channel = Model.SelectorType (Channel) let t = - let decode (id, (user_uuid, (channel, (token, (usage_count, ()))))) = - Ok { id; user_uuid; channel; token; usage_count = UsageCount.of_int usage_count } + 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; UsageCount.value m.usage_count ] + Ok + Data. + [ m.id + ; m.user_uuid + ; m.channel + ; m.token + ; FailedAttempts.value m.failed_attempts + ] in let open Schema in custom @@ -26,7 +39,7 @@ let sql_select_columns = ; Entity.Id.sql_select_fragment ~field:"pool_authentication.user_uuid" ; "pool_authentication.channel" ; "pool_authentication.token" - ; "pool_authentication.usage_count" + ; "pool_authentication.failed_attempts" ] ;; @@ -37,7 +50,7 @@ let insert_request = user_uuid, channel, token, - usage_count, + failed_attempts, valid_until ) VALUES ( UNHEX(REPLACE($1, '-', '')), @@ -64,10 +77,10 @@ let find_valid_by_id_request = FROM pool_authentication WHERE uuid = UNHEX(REPLACE($1, '-', '')) AND valid_until > NOW() - AND usage_count < %d + AND failed_attempts < %d |sql} (CCString.concat ", " sql_select_columns) - UsageCount.(value limit) + FailedAttempts.(value limit) |> Pool_common.Repo.Id.t ->? Repo_entity.t ;; @@ -107,17 +120,17 @@ let delete_request = let delete pool id = Database.exec pool delete_request id -let increase_usage_count_request = +let increase_failed_attempts_request = {sql| UPDATE pool_authentication - SET usage_count = usage_count + 1 + SET failed_attempts = failed_attempts + 1 WHERE uuid = UNHEX(REPLACE($1, '-', '')) |sql} |> Pool_common.Repo.Id.t ->. Caqti_type.unit ;; -let increase_usage_count pool { id; _ } = - Database.exec pool increase_usage_count_request id +let increase_failed_attempts pool { id; _ } = + Database.exec pool increase_failed_attempts_request id ;; let reset_expired_request = diff --git a/pool/app/pool_database/migrations/migration_202607141227.ml b/pool/app/pool_database/migrations/migration_202607141227.ml index 85ca34c82..8df85217d 100644 --- a/pool/app/pool_database/migrations/migration_202607141227.ml +++ b/pool/app/pool_database/migrations/migration_202607141227.ml @@ -27,12 +27,12 @@ let remove_automagic_timestamp_on_update_trigger = |sql} ;; -let add_usage_count_to_authentication = +let add_failed_attempts_to_authentication = Migration.Step.create - ~label:"add usage_count to pool_authentication" + ~label:"add failed_attempts column to pool_authentication" {sql| ALTER TABLE pool_authentication - ADD COLUMN usage_count TINYINT UNSIGNED NOT NULL DEFAULT 0 AFTER token + ADD COLUMN failed_attempts TINYINT UNSIGNED NOT NULL DEFAULT 0 AFTER token |sql} ;; @@ -41,5 +41,5 @@ let migration () = empty "202607141227" |> add_step create_pool_queue_job_authentication_table |> add_step remove_automagic_timestamp_on_update_trigger - |> add_step add_usage_count_to_authentication) + |> add_step add_failed_attempts_to_authentication) ;; diff --git a/pool/web/handler/helpers_login.ml b/pool/web/handler/helpers_login.ml index 0eb1717e4..40c25b13b 100644 --- a/pool/web/handler/helpers_login.ml +++ b/pool/web/handler/helpers_login.ml @@ -320,11 +320,12 @@ let verify_2fa_login ~tags { Pool_context.database_label; user = context_user; _ Pool_event.handle_events database_label context_user - [ Authentication.IncreaseUsageCount auth |> Pool_event.authentication ] + [ Authentication.IncreaseFailedAttempts auth |> Pool_event.authentication + ] in let remaining = - Authentication.UsageCount.( - value limit - value auth.Authentication.usage_count) + Authentication.FailedAttempts.( + value limit - value auth.Authentication.failed_attempts) - 1 in if remaining <= 0