yesod-auth 1.6.3 → 1.6.4
raw patch · 3 files changed
+143/−72 lines, 3 filesdep −byteabledep −mime-maildep −networkdep ~http-client
Dependencies removed: byteable, mime-mail, network, persistent-template, resourcet
Dependency ranges changed: http-client
Files
- ChangeLog.md +19/−0
- Yesod/Auth/Email.hs +96/−36
- yesod-auth.cabal +28/−36
ChangeLog.md view
@@ -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)
Yesod/Auth/Email.hs view
@@ -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
yesod-auth.cabal view
@@ -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