diff --git a/pool/app/authentication/authentication.ml b/pool/app/authentication/authentication.ml index 2f760a8fc..4317c03c0 100644 --- a/pool/app/authentication/authentication.ml +++ b/pool/app/authentication/authentication.ml @@ -5,10 +5,16 @@ let label = "reset OTP (authentication codes)" let src = Logs.Src.create "authentication.service" let create ?(id = Id.create ()) ?(token = Token.generate ()) ~user ~channel () = - { id; user_uuid = Pool_user.id user; channel; token } + { id + ; user_uuid = Pool_user.id user + ; channel + ; token + ; failed_attempts = FailedAttempts.of_int 0 + } ;; let find_valid_by_id = Repo.find_valid_by_id +let find_id_by_user = Repo.find_id_by_user let start () = let open Schedule in diff --git a/pool/app/authentication/authentication.mli b/pool/app/authentication/authentication.mli index 8fd619f1d..95fdcf2c2 100644 --- a/pool/app/authentication/authentication.mli +++ b/pool/app/authentication/authentication.mli @@ -21,13 +21,26 @@ module Token : sig val schema : unit -> (Pool_conformist.error_msg, t) Pool_conformist.Field.t end +module FailedAttempts : sig + type t + + val equal : t -> t -> bool + val pp : Format.formatter -> t -> unit + val show : t -> string + val value : t -> int + val of_int : int -> t + val limit : t +end + type t = { id : Id.t ; user_uuid : Pool_user.Id.t ; channel : Channel.t ; token : Token.t + ; failed_attempts : FailedAttempts.t } +val resend_cooldown_seconds : int val equal : t -> t -> bool val show : t -> string val pp : Format.formatter -> t -> unit @@ -42,7 +55,8 @@ val create type event = | Created of t - | Deleted of t + | Deleted of Id.t + | IncreaseFailedAttempts of t | ResetExpired val equal_event : event -> event -> bool @@ -55,5 +69,6 @@ val find_valid_by_id -> Id.t -> (t * Pool_user.t, Pool_message.Error.t) Lwt_result.t +val find_id_by_user : Database.Label.t -> Pool_user.Id.t -> Id.t option Lwt.t val lifecycle : Sihl.Container.lifecycle val register : unit -> Sihl.Container.Service.t diff --git a/pool/app/authentication/entity.ml b/pool/app/authentication/entity.ml index 56b06020b..18b86d40e 100644 --- a/pool/app/authentication/entity.ml +++ b/pool/app/authentication/entity.ml @@ -18,6 +18,12 @@ module Channel = struct include Core end +module FailedAttempts = struct + include Pool_model.Base.Integer + + let limit = of_int 3 +end + module Token = struct include Pool_model.Base.String @@ -47,5 +53,8 @@ type t = ; user_uuid : Pool_user.Id.t ; channel : Channel.t ; token : Token.t + ; failed_attempts : FailedAttempts.t } [@@deriving eq, show { with_path = false }] + +let resend_cooldown_seconds = 60 diff --git a/pool/app/authentication/event.ml b/pool/app/authentication/event.ml index 21e3a8bff..533024d8a 100644 --- a/pool/app/authentication/event.ml +++ b/pool/app/authentication/event.ml @@ -2,12 +2,14 @@ open Entity type event = | Created of t - | Deleted of t + | Deleted of Id.t + | IncreaseFailedAttempts of t | ResetExpired [@@deriving eq, show] let handle_event pool = function | Created t -> Repo.insert pool t | Deleted t -> Repo.delete pool t + | IncreaseFailedAttempts t -> Repo.increase_failed_attempts pool t | ResetExpired -> Repo.reset_expired pool () ;; diff --git a/pool/app/authentication/repo.ml b/pool/app/authentication/repo.ml index 2d12fcfe7..7184f057d 100644 --- a/pool/app/authentication/repo.ml +++ b/pool/app/authentication/repo.ml @@ -7,14 +7,30 @@ module Repo_entity = struct module Channel = Model.SelectorType (Channel) let t = - let decode (id, (user_uuid, (channel, (token, ())))) = - Ok { id; user_uuid; channel; token } + let decode (id, (user_uuid, (channel, (token, (failed_attempts, ()))))) = + Ok + { id + ; user_uuid + ; channel + ; token + ; failed_attempts = FailedAttempts.of_int failed_attempts + } in let encode m : ('a Data.t, string) result = - Ok Data.[ m.id; m.user_uuid; m.channel; m.token ] + Ok + Data. + [ m.id + ; m.user_uuid + ; m.channel + ; m.token + ; FailedAttempts.value m.failed_attempts + ] in let open Schema in - custom ~encode ~decode Caqti_type.[ Id.t; Pool_user.Repo.Id.t; Channel.t; string ] + custom + ~encode + ~decode + Caqti_type.[ Id.t; Pool_user.Repo.Id.t; Channel.t; string; int ] ;; end @@ -23,6 +39,7 @@ let sql_select_columns = ; Entity.Id.sql_select_fragment ~field:"pool_authentication.user_uuid" ; "pool_authentication.channel" ; "pool_authentication.token" + ; "pool_authentication.failed_attempts" ] ;; @@ -33,15 +50,16 @@ let insert_request = user_uuid, channel, token, + failed_attempts, valid_until ) VALUES ( UNHEX(REPLACE($1, '-', '')), UNHEX(REPLACE($2, '-', '')), $3, $4, + $5, NOW() + INTERVAL 5 MINUTE ) ON DUPLICATE KEY UPDATE - uuid = UNHEX(REPLACE($1, '-', '')), channel = $3, token = $4, valid_until = NOW() + INTERVAL 5 MINUTE @@ -59,8 +77,10 @@ let find_valid_by_id_request = FROM pool_authentication WHERE uuid = UNHEX(REPLACE($1, '-', '')) AND valid_until > NOW() + AND failed_attempts < %d |sql} (CCString.concat ", " sql_select_columns) + FailedAttempts.(value limit) |> Pool_common.Repo.Id.t ->? Repo_entity.t ;; @@ -74,6 +94,22 @@ let find_valid_by_id pool id = Lwt_result.return (auth, user) ;; +let find_id_by_user_request = + Format.asprintf + {sql| + SELECT + %s + FROM pool_authentication + WHERE user_uuid = UNHEX(REPLACE($1, '-', '')) + |sql} + (Entity.Id.sql_select_fragment ~field:"pool_authentication.uuid") + |> Pool_user.Repo.Id.t ->? Pool_common.Repo.Id.t +;; + +let find_id_by_user pool user_uuid = + Database.find_opt pool find_id_by_user_request user_uuid +;; + let delete_request = {sql| DELETE FROM pool_authentication @@ -82,7 +118,20 @@ let delete_request = |> Pool_common.Repo.Id.t ->. Caqti_type.unit ;; -let delete pool { id; _ } = Database.exec pool delete_request id +let delete pool id = Database.exec pool delete_request id + +let increase_failed_attempts_request = + {sql| + UPDATE pool_authentication + SET failed_attempts = failed_attempts + 1 + WHERE uuid = UNHEX(REPLACE($1, '-', '')) + |sql} + |> Pool_common.Repo.Id.t ->. Caqti_type.unit +;; + +let increase_failed_attempts pool { id; _ } = + Database.exec pool increase_failed_attempts_request id +;; let reset_expired_request = {sql| diff --git a/pool/app/message_template/message_template.ml b/pool/app/message_template/message_template.ml index 4412df89f..5030082c8 100644 --- a/pool/app/message_template/message_template.ml +++ b/pool/app/message_template/message_template.ml @@ -23,6 +23,11 @@ module History = struct let user_uuid user = user.Pool_user.id |> Pool_user.Id.to_common let admin_item { Admin.user; _ } = User, user_uuid user let assignment_item { Assignment.id; _ } = Assignment, Assignment.(id |> Id.to_common) + + let authentication_item { Authentication.id; _ } = + Authentication, Pool_common.Id.of_string (Authentication.Id.value id) + ;; + let contact_item { Contact.user; _ } = User, user_uuid user let experiment_item experiment = @@ -778,7 +783,7 @@ module Login2FAToken = struct layout (email_params layout user auth.Authentication.token) in - create_email_job label [] email + create_email_job label [ History.authentication_item auth ] email in Lwt.return fnc ;; 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..8df85217d --- /dev/null +++ b/pool/app/pool_database/migrations/migration_202607141227.ml @@ -0,0 +1,45 @@ +open Database + +let create_pool_queue_job_authentication_table = + Migration.Step.create + ~label:"create pool_queue_job_authentication table" + {sql| + CREATE TABLE IF NOT EXISTS pool_queue_job_authentication ( + queue_uuid binary(16) NOT NULL, + authentication_uuid binary(16) NOT NULL, + created_at timestamp NOT NULL DEFAULT CURRENT_TIMESTAMP, + updated_at timestamp NOT NULL DEFAULT CURRENT_TIMESTAMP ON UPDATE CURRENT_TIMESTAMP, + UNIQUE KEY `unique_queue_uuid` (`queue_uuid`), + UNIQUE KEY `unique_queue_entity_combination` (queue_uuid, authentication_uuid), + KEY `idx_authentication_uuid` (`authentication_uuid`), + CONSTRAINT fk_pool_queue_job_authentication FOREIGN KEY (authentication_uuid) REFERENCES pool_authentication(uuid) ON DELETE CASCADE + ) ENGINE=InnoDB DEFAULT CHARSET=utf8mb4 COLLATE=utf8mb4_unicode_ci; + |sql} +;; + +let remove_automagic_timestamp_on_update_trigger = + Migration.Step.create + ~label: + "remove mariadbs automagic timestamp on update trigger for token valid_until column" + {sql| + ALTER TABLE pool_authentication + MODIFY COLUMN valid_until TIMESTAMP NOT NULL DEFAULT CURRENT_TIMESTAMP() + |sql} +;; + +let add_failed_attempts_to_authentication = + Migration.Step.create + ~label:"add failed_attempts column to pool_authentication" + {sql| + ALTER TABLE pool_authentication + ADD COLUMN failed_attempts TINYINT UNSIGNED NOT NULL DEFAULT 0 AFTER token + |sql} +;; + +let migration () = + Migration.( + empty "202607141227" + |> add_step create_pool_queue_job_authentication_table + |> add_step remove_automagic_timestamp_on_update_trigger + |> add_step add_failed_attempts_to_authentication) +;; diff --git a/pool/app/pool_database/root.ml b/pool/app/pool_database/root.ml index 860d8cfa9..9c3803c31 100644 --- a/pool/app/pool_database/root.ml +++ b/pool/app/pool_database/root.ml @@ -35,6 +35,7 @@ let steps = ; Migration_202607031400.migration () ; Migration_202607051000.migration () ; Migration_202607061500.migration_root () + ; Migration_202607141227.migration () ] |> sort in diff --git a/pool/app/pool_database/tenant.ml b/pool/app/pool_database/tenant.ml index 96368ca85..6466b3e19 100644 --- a/pool/app/pool_database/tenant.ml +++ b/pool/app/pool_database/tenant.ml @@ -102,6 +102,7 @@ let steps = ; Migration_202607071000.migration () ; Migration_202607071200.migration () ; Migration_202607071300.migration () + ; Migration_202607141227.migration () ] |> sort in 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/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 f953c1d3f..850a77802 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 b1b89154c..d9d7cb3d7 100644 --- a/pool/pool_queue/repo.ml +++ b/pool/pool_queue/repo.ml @@ -382,6 +382,29 @@ let cancel_undeliverable_email_jobs label = Database.exec label cancel_undeliverable_email_jobs_request () ;; +let find_last_login_token_sent_at_request = + let open Caqti_request.Infix in + let auth_uuid_fragment = Pool_common.Id.sql_value_fragment "?" in + [%string + {sql| + SELECT jobs.persisted_at + FROM ( + SELECT uuid, persisted_at FROM pool_queue_jobs + UNION ALL + SELECT uuid, persisted_at FROM pool_queue_jobs_history + ) AS jobs + JOIN pool_queue_job_authentication auth ON auth.queue_uuid = jobs.uuid + WHERE auth.authentication_uuid = %{auth_uuid_fragment} + ORDER BY jobs.persisted_at DESC + LIMIT 1 + |sql}] + |> Pool_common.Repo.Id.t ->? Caqti_type.ptime +;; + +let find_last_login_token_sent_at pool auth_id = + Database.find_opt pool find_last_login_token_sent_at_request auth_id +;; + let find_archivable_request = [%string {sql| diff --git a/pool/routes/routes.ml b/pool/routes/routes.ml index db809a74c..331180df8 100644 --- a/pool/routes/routes.ml +++ b/pool/routes/routes.ml @@ -109,7 +109,9 @@ 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 "/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 @@ -992,7 +994,9 @@ 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 + ; 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/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 c5d03f542..40c25b13b 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" @@ -146,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 @@ -261,3 +267,188 @@ 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 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 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 auth_id) + | 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.IncreaseFailedAttempts auth |> Pool_event.authentication + ] + in + let remaining = + Authentication.FailedAttempts.( + value limit - value auth.Authentication.failed_attempts) + - 1 + in + if remaining <= 0 + then ( + let%lwt () = + increment_failed_login_attempt + ~tags + database_label + (Pool_user.email user) + in + 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 (_ : Error.t) -> + 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 () + >|+ Sihl.Web.Session.update_or_set_value ~key:"auth_id" (fun _ -> None) req + | 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 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 < Authentication.resend_cooldown_seconds + then Error Pool_message.Error.TokenAlreadySentRecently + else Ok ()) + |> Lwt_result.lift + in + 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 + 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 ea4406e70..3d30df2bf 100644 --- a/pool/web/handler/public_login.ml +++ b/pool/web/handler/public_login.ml @@ -32,46 +32,24 @@ 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 + (HttpUtils.retain_url_params req "/login/verify" |> Uri.to_string) + [ Sihl.Web.Session.set + [ "auth_id", auth.Authentication.id |> Authentication.Id.value ] + ] 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 = @@ -96,18 +74,26 @@ let login_post req = Response.handle ~src req result ;; -let login_cofirmation req = +let login_verify_get req = + 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 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 login Pool_context.{ database_label; query_parameters; _ } user = let success_and_redirect ?(set_completion_cookie = false) ?redirect @@ -121,8 +107,6 @@ let login_cofirmation 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 redirect_to_with_actions redirect @@ -167,9 +151,27 @@ let login_cofirmation req = | true -> handle_admin_login user | false -> handle_contact_login user) in - Response.handle ~src req result + 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 + 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 cae27a3bd..9c8bb0e18 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,46 +34,55 @@ 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 = + Helpers_login.login_verify_get + ~login_path:root_login_path + ~render_confirmation:(fun context auth user -> 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 + >|> General.create_root_layout ~active_navigation:"/root/login" context ||> Sihl.Web.Response.of_html - in - events |> handle_events >|> success |> Lwt_result.ok - in - Response.handle ~src req result + |> Lwt_result.ok) + req ;; -let confirmation_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 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 ] ] - in - events |> handle_events >|> success |> Lwt_result.ok - in - handle ~src req result + |> 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) ;; +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 b070d04df..f255a807b 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,6 +28,89 @@ let login_token_confirmation | Some id -> input_element language `Hidden Pool_message.Field.Id ~value:(Id.value id) | None -> txt "" in + let resend_token sent_at = + 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 (Authentication.resend_cooldown_seconds - elapsed) + in + let resend_action = + HttpUtils.externalize_path_with_params + query_parameters + (Format.asprintf "%s/resend-token" url) + 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 interval = setInterval(() => { + const remaining = Math.max(0, Math.ceil((deadline - Date.now()) / 1000)); + + if (remaining > 0) { + countdown.textContent = remaining; + } else { + button.disabled = false; + countdown.remove(); + + clearInterval(interval); + } + }, 1000); +})(); + |js} + button_id + countdown_id + in + div + ~a:[ a_class [ "flexrow"; "flex-gap-sm" ] ] + ([ button + ~a: + [ a_button_type `Button + ; 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 @@ -52,6 +136,7 @@ let login_token_confirmation language `Text Pool_message.Field.OTP + ; resend_token ; div ~a:[ a_class [ "flexrow"; "align-center"; "flex-gap" ] ] [ submit_element 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; _ } =