diff --git a/pool/web/handler/contact_signup.ml b/pool/web/handler/contact_signup.ml index 9dd1ebefb..c580f6364 100644 --- a/pool/web/handler/contact_signup.ml +++ b/pool/web/handler/contact_signup.ml @@ -57,6 +57,14 @@ let sign_up_create req = ||> CCOption.to_result ContactSignupInvalidEmail >== Pool_user.EmailAddress.create in + let log_request () = + Logging_helper.log_request_with_ip + ~src + "User registration" + req + tags + email_address + in let create_contact_events () = let open Command.SignUp in let* ({ firstname; lastname; _ } as decoded) = @@ -92,39 +100,48 @@ let sign_up_create req = in let* events = match existing_user with - | None -> create_contact_events () + | None -> + let* events = create_contact_events () in + log_request (); + Lwt_result.return events | Some user when Service.User.is_admin user -> Lwt_result.return [] | Some _ -> let%lwt contact = email_address |> Contact.find_by_email database_label in - contact - |> (function - | Ok contact when contact.Contact.user.Sihl_user.confirmed -> - let%lwt send_notification = - Contact.should_send_registration_attempt_notification - database_label - contact - in - if not send_notification - then Lwt_result.return [] - else - contact - |> Message_template.ContactRegistrationAttempt.create - database_label - (CCOption.value ~default:language contact.Contact.language) - tenant - ||> Command.SendRegistrationAttemptNotifitacion.handle - ~tags - contact - | Ok contact -> - let* create_contact_events = create_contact_events () in - let open CCResult.Infix in - contact - |> Command.DeleteUnverified.handle ~tags - >|= CCFun.flip CCList.append create_contact_events - |> Lwt_result.lift - | Error _ -> Lwt_result.return []) + let* events = + contact + |> function + | Ok contact when contact.Contact.user.Sihl_user.confirmed -> + let%lwt send_notification = + Contact.should_send_registration_attempt_notification + database_label + contact + in + if not send_notification + then Lwt_result.return [] + else + contact + |> Message_template.ContactRegistrationAttempt.create + database_label + (CCOption.value + ~default:language + contact.Contact.language) + tenant + ||> Command.SendRegistrationAttemptNotifitacion.handle + ~tags + contact + | Ok contact -> + let* create_contact_events = create_contact_events () in + let open CCResult.Infix in + contact + |> Command.DeleteUnverified.handle ~tags + >|= CCFun.flip CCList.append create_contact_events + |> Lwt_result.lift + | Error _ -> Lwt_result.return [] + in + log_request (); + Lwt_result.return events in let%lwt () = Pool_event.handle_events ~tags database_label events in HttpUtils.( diff --git a/pool/web/handler/helpers_login.ml b/pool/web/handler/helpers_login.ml index acb0921a0..d323f3efb 100644 --- a/pool/web/handler/helpers_login.ml +++ b/pool/web/handler/helpers_login.ml @@ -86,16 +86,7 @@ let login_params urlencoded = Lwt_result.return (email, password) ;; -let log_request req tags email = - let open Opium in - let open Request in - let ip = - Headers.get req.headers "X-Real-IP" - |> CCOption.value ~default:"X-Real-IP not found" - in - Logs.warn ~src (fun m -> - m "Failed login attempt: %s %s" ip (EmailAddress.value email) ~tags) -;; +let log_request = Logging_helper.log_request_with_ip ~src "Failed login attempt" let login req urlencoded database_label = let open Utils.Lwt_result.Infix in diff --git a/pool/web/handler/logging_helper.ml b/pool/web/handler/logging_helper.ml new file mode 100644 index 000000000..ea6768c9d --- /dev/null +++ b/pool/web/handler/logging_helper.ml @@ -0,0 +1,10 @@ +let log_request_with_ip ~src message req tags email = + let open Opium in + let open Request in + let ip = + Headers.get req.headers "X-Real-IP" + |> CCOption.value ~default:"X-Real-IP not found" + in + Logs.warn ~src (fun m -> + m "%s: %s %s" message ip (Pool_user.EmailAddress.value email) ~tags) +;;