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

@@ -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)

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 _ verStatus (Just key) email) -> return $ Just (lid, verStatus, key, email)
-                    Just (EmailCreds lid _ _ Nothing email) -> do
+                    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
+                Just creds@(_, False, _, _) -> sendConfirmationEmail creds
-                    render <- getUrlRender
+                Just creds@(_, True, _, _) -> do
-                    tp <- getRouteToParent
+                  case emailPreviouslyRegisteredResponse identifier of
-                    let verUrl = render $ tp $ verifyR (toPathPiece lid) verKey
+                    Just response -> response
-                    sendVerifyEmail email verKey verUrl
+                    Nothing -> sendConfirmationEmail creds
-                    confirmationEmailSentResponse identifier
+              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

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