From 8d58a56577eb6ff5acd1974a8790088d26e5e0cb Mon Sep 17 00:00:00 2001
From: Steven Leiva <leiva.steven@gmail.com>
Date: Fri, 8 Jun 2018 15:49:30 -0500
Subject: [PATCH] Make behavior of `registerHelper` configurable.

The behavior of `registerHelper` when an email that is already-verified
tries to register is now configurable via the
`emailPreviouslyRegisteredResponse` method of the `YesodAuthEmail`
typeclass.
---
 yesod-auth/ChangeLog.md        |  4 ++++
 yesod-auth/Yesod/Auth/Email.hs | 35 +++++++++++++++++++++++-----------
 yesod-auth/yesod-auth.cabal    |  2 +-
 3 files changed, 29 insertions(+), 12 deletions(-)

diff --git a/yesod-auth/ChangeLog.md b/yesod-auth/ChangeLog.md
index a22f1e32..1280ad13 100644
--- a/yesod-auth/ChangeLog.md
+++ b/yesod-auth/ChangeLog.md
@@ -1,3 +1,7 @@
+## 1.6.4
+
+* Make `registerHelper` configurable [#1524](https://github.com/yesodweb/yesod/issues/1524)
+
 ## 1.6.3
 
 * Generalize GoogleEmail2.getPerson [#1501](https://github.com/yesodweb/yesod/pull/1501)
diff --git a/yesod-auth/Yesod/Auth/Email.hs b/yesod-auth/Yesod/Auth/Email.hs
index 38afc51e..3060dd7a 100644
--- a/yesod-auth/Yesod/Auth/Email.hs
+++ b/yesod-auth/Yesod/Auth/Email.hs
@@ -299,6 +299,14 @@ class ( YesodAuth site
       where
         msg = Msg.ConfirmationEmailSent identifier
 
+    -- | If a response is set, it will be used when an already-verified email
+    -- tries to re-register. Otherwise, `confirmationEmailSentResponse` will be
+    -- used.
+    --
+    -- @since 1.6.4
+    emailPreviouslyRegisteredResponse :: MonadAuthHandler site m => Text -> Maybe (m TypedContent)
+    emailPreviouslyRegisteredResponse _ = Nothing
+
     -- | Additional normalization of email addresses, besides standard canonicalization.
     --
     -- Default: Lower case the email address.
@@ -508,26 +516,31 @@ registerHelper allowUsername dest = do
             mecreds <- getEmailCreds identifier
             registerCreds <-
                 case mecreds of
-                    Just (EmailCreds lid _ _ (Just key) email) -> return $ Just (lid, key, email)
-                    Just (EmailCreds lid _ _ Nothing email) -> do
+                    Just (EmailCreds lid _ verStatus (Just key) email) -> return $ Just (lid, verStatus, key, email)
+                    Just (EmailCreds lid _ verStatus Nothing email) -> do
                         key <- liftIO $ randomKey y
                         setVerifyKey lid key
-                        return $ Just (lid, key, email)
+                        return $ Just (lid, verStatus, key, email)
                     Nothing
                         | allowUsername -> return Nothing
                         | otherwise -> do
                             key <- liftIO $ randomKey y
                             lid <- addUnverified identifier key
-                            return $ Just (lid, key, identifier)
-
+                            return $ Just (lid, False, key, identifier)
             case registerCreds of
                 Nothing -> loginErrorMessageI dest (Msg.IdentifierNotFound identifier)
-                Just (lid, verKey, email) -> do
-                    render <- getUrlRender
-                    tp <- getRouteToParent
-                    let verUrl = render $ tp $ verifyR (toPathPiece lid) verKey
-                    sendVerifyEmail email verKey verUrl
-                    confirmationEmailSentResponse identifier
+                Just creds@(_, False, _, _) -> sendConfirmationEmail creds
+                Just creds@(_, True, _, _) -> do
+                  case emailPreviouslyRegisteredResponse identifier of
+                    Just response -> response
+                    Nothing -> sendConfirmationEmail creds
+              where sendConfirmationEmail (lid, _, verKey, email) = do
+                      render <- getUrlRender
+                      tp <- getRouteToParent
+                      let verUrl = render $ tp $ verifyR (toPathPiece lid) verKey
+                      sendVerifyEmail email verKey verUrl
+                      confirmationEmailSentResponse identifier
+
 
 postRegisterR :: YesodAuthEmail master => AuthHandler master TypedContent
 postRegisterR = registerHelper False registerR
diff --git a/yesod-auth/yesod-auth.cabal b/yesod-auth/yesod-auth.cabal
index 22298eb7..120950cc 100644
--- a/yesod-auth/yesod-auth.cabal
+++ b/yesod-auth/yesod-auth.cabal
@@ -1,5 +1,5 @@
 name:            yesod-auth
-version:         1.6.3
+version:         1.6.4
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman, Patrick Brisbin