diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,22 @@ +# ChangeLog for yesod-auth + +## 1.6.4 + +* Make `registerHelper` configurable [#1524](https://github.com/yesodweb/yesod/issues/1524) +* Email: Immediately register with a password [#1389](https://github.com/yesodweb/yesod/issues/1389) +To configure this new functionality: + 1. Define `addUnverifiedWithPass`, e.g: + ``` + addUnverified email verkey = liftHandler $ runDB $ do + void $ insert $ UserLogin email Nothing (Just verkey) False + return email + + addUnverifiedWithPass email verkey pass = liftHandler $ runDB $ do + void $ insert $ UserLogin email (Just pass) (Just verkey) False + return email + ``` + 2. Add a `password` field to your client forms. + ## 1.6.3 * Generalize GoogleEmail2.getPerson [#1501](https://github.com/yesodweb/yesod/pull/1501) diff --git a/Yesod/Auth/Email.hs b/Yesod/Auth/Email.hs --- a/Yesod/Auth/Email.hs +++ b/Yesod/Auth/Email.hs @@ -44,7 +44,10 @@ -- @ -- Endpoint: \/auth\/page\/email\/register -- Method: POST --- JSON Data: { "email": "myemail@domain.com" } +-- JSON Data: { +-- "email": "myemail@domain.com", +-- "password": "myStrongPassword" (optional) +-- } -- @ -- -- * Forgot password @@ -141,11 +144,15 @@ forgotPasswordR = PluginR "email" ["forgot-password"] setpassR = PluginR "email" ["set-password"] +verifyURLHasSetPassText :: Text +verifyURLHasSetPassText = "has-set-pass" + -- | -- -- @since 1.4.5 -verifyR :: Text -> Text -> AuthRoute -- FIXME -verifyR eid verkey = PluginR "email" ["verify", eid, verkey] +verifyR :: Text -> Text -> Bool -> AuthRoute -- FIXME +verifyR eid verkey hasSetPass = PluginR "email" path + where path = "verify":eid:verkey:(if hasSetPass then [verifyURLHasSetPassText] else []) type Email = Text type VerKey = Text @@ -188,6 +195,14 @@ -- @since 1.1.0 addUnverified :: Email -> VerKey -> AuthHandler site (AuthEmailId site) + -- | Similar to `addUnverified`, but comes with the registered password + -- the default implementation is just `addUnverified`, which ignores the password + -- you may override this to save the salted password to your database + -- + -- @since 1.6.4 + addUnverifiedWithPass :: Email -> VerKey -> SaltedPass -> AuthHandler site (AuthEmailId site) + addUnverifiedWithPass email verkey _ = addUnverified email verkey + -- | Send an email to the given address to verify ownership. -- -- @since 1.1.0 @@ -262,6 +277,12 @@ -- @since 1.2.0 afterPasswordRoute :: site -> Route site + -- | Route to send user to after verification with a password + -- + -- @since 1.6.4 + afterVerificationWithPass :: site -> Route site + afterVerificationWithPass = afterPasswordRoute + -- | Does the user need to provide the current password in order to set a -- new password? -- @@ -299,6 +320,14 @@ 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. @@ -365,7 +394,11 @@ dispatch "GET" ["verify", eid, verkey] = case fromPathPiece eid of Nothing -> notFound - Just eid' -> getVerifyR eid' verkey >>= sendResponse + Just eid' -> getVerifyR eid' verkey False >>= sendResponse + dispatch "GET" ["verify", eid, verkey, hasSetPass] = + case fromPathPiece eid of + Nothing -> notFound + Just eid' -> getVerifyR eid' verkey (hasSetPass == verifyURLHasSetPassText) >>= sendResponse dispatch "POST" ["login"] = postLoginR >>= sendResponse dispatch "GET" ["set-password"] = getPasswordR >>= sendResponse dispatch "POST" ["set-password"] = postPasswordR >>= sendResponse @@ -475,62 +508,82 @@ return (userRes, widget) -parseEmail :: Value -> Parser Text -parseEmail = withObject "email" (\obj -> do - email' <- obj .: "email" - return email') +parseRegister :: Value -> Parser (Text, Maybe Text) +parseRegister = withObject "email" (\obj -> do + email <- obj .: "email" + pass <- obj .:? "password" + return (email, pass)) registerHelper :: YesodAuthEmail master => Bool -- ^ allow usernames? + -> Bool -- ^ allow password? -> Route Auth -> AuthHandler master TypedContent -registerHelper allowUsername dest = do +registerHelper allowUsername allowPassword dest = do y <- getYesod checkCsrfHeaderOrParam defaultCsrfHeaderName defaultCsrfParamName - pidentifier <- lookupPostParam "email" - midentifier <- case pidentifier of - Nothing -> do - (jidentifier :: Result Value) <- parseCheckJsonBody - case jidentifier of - Error _ -> return Nothing - Success val -> return $ parseMaybe parseEmail val - Just _ -> return pidentifier - let eidentifier = case midentifier of + result <- runInputPostResult $ (,) + <$> ireq textField "email" + <*> iopt textField "password" + + creds <- case result of + FormSuccess (iden, pass) -> return $ Just (iden, pass) + _ -> do + (creds :: Result Value) <- parseCheckJsonBody + return $ case creds of + Error _ -> Nothing + Success val -> parseMaybe parseRegister val + + let eidentifier = case creds of Nothing -> Left Msg.NoIdentifierProvided - Just x + Just (x, _) | Just x' <- Text.Email.Validate.canonicalizeEmail (encodeUtf8 x) -> Right $ normalizeEmailAddress y $ decodeUtf8With lenientDecode x' | allowUsername -> Right $ TS.strip x | otherwise -> Left Msg.InvalidEmailAddress + + let mpass = case (allowPassword, creds) of + (True, Just (_, mp)) -> mp + _ -> Nothing + case eidentifier of Left route -> loginErrorMessageI dest route Right identifier -> 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) - + lid <- case mpass of + Just pass -> do + salted <- hashAndSaltPassword pass + addUnverifiedWithPass identifier key salted + _ -> addUnverified identifier key + 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 (isJust mpass) + sendVerifyEmail email verKey verUrl + confirmationEmailSentResponse identifier + postRegisterR :: YesodAuthEmail master => AuthHandler master TypedContent -postRegisterR = registerHelper False registerR +postRegisterR = registerHelper False True registerR getForgotPasswordR :: YesodAuthEmail master => AuthHandler master Html getForgotPasswordR = forgotPasswordHandler @@ -574,13 +627,14 @@ } postForgotPasswordR :: YesodAuthEmail master => AuthHandler master TypedContent -postForgotPasswordR = registerHelper True forgotPasswordR +postForgotPasswordR = registerHelper True False forgotPasswordR getVerifyR :: YesodAuthEmail site => AuthEmailId site -> Text + -> Bool -> AuthHandler site TypedContent -getVerifyR lid key = do +getVerifyR lid key hasSetPass = do realKey <- getVerifyKey lid memail <- getEmail lid mr <- getMessageRender @@ -596,8 +650,14 @@ selectRep $ do provideRep $ do addMessageI "success" msgAv - tp <- getRouteToParent - fmap asHtml $ redirect $ tp setpassR + redirectRoute <- if hasSetPass + then do + y <- getYesod + return $ afterVerificationWithPass y + else do + tp <- getRouteToParent + return $ tp setpassR + fmap asHtml $ redirect redirectRoute provideJsonMessage $ mr msgAv _ -> invalidKey mr where diff --git a/yesod-auth.cabal b/yesod-auth.cabal --- a/yesod-auth.cabal +++ b/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 @@ -21,54 +21,46 @@ library build-depends: base >= 4 && < 5 + , aeson >= 0.7 , authenticate >= 1.3.4 - , bytestring >= 0.9.1.4 - , yesod-core >= 1.6 && < 1.7 - , wai >= 1.4 - , template-haskell , base16-bytestring - , cryptonite - , memory - , random >= 1.0.0.2 - , text >= 0.7 - , mime-mail >= 0.3 - , yesod-persistent >= 1.6 - , shakespeare + , base64-bytestring + , binary + , blaze-builder + , blaze-html >= 0.5 + , blaze-markup >= 0.5.1 + , bytestring >= 0.9.1.4 + , conduit >= 1.3 + , conduit-extra , containers - , unordered-containers - , yesod-form >= 1.6 && < 1.7 - , transformers >= 0.2.2 - , persistent >= 2.8 && < 2.9 - , persistent-template >= 2.1 && < 2.8 + , cryptonite + , data-default + , email-validate >= 1.0 + , file-embed , http-client >= 0.5 , http-client-tls , http-conduit >= 2.1 - , aeson >= 0.7 - , unliftio - , blaze-html >= 0.5 - , blaze-markup >= 0.5.1 , http-types - , file-embed - , email-validate >= 1.0 - , data-default - , resourcet + , memory + , nonce >= 1.0.2 && < 1.1 + , persistent >= 2.8 && < 2.9 + , random >= 1.0.0.2 , safe + , shakespeare + , template-haskell + , text >= 0.7 , time - , base64-bytestring - , byteable - , binary - , http-client - , blaze-builder - , conduit >= 1.3 - , conduit-extra - , nonce >= 1.0.2 && < 1.1 - , unliftio-core + , transformers >= 0.2.2 , unliftio + , unliftio-core + , unordered-containers + , wai >= 1.4 + , yesod-core >= 1.6 && < 1.7 + , yesod-form >= 1.6 && < 1.7 + , yesod-persistent >= 1.6 if flag(network-uri) build-depends: network-uri >= 2.6 - else - build-depends: network < 2.6 exposed-modules: Yesod.Auth Yesod.Auth.BrowserId