commit ghc-yesod-auth for openSUSE:Factory
Hello community, here is the log from the commit of package ghc-yesod-auth for openSUSE:Factory checked in at 2017-03-16 09:35:55 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-yesod-auth (Old) and /work/SRC/openSUSE:Factory/.ghc-yesod-auth.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-yesod-auth" Thu Mar 16 09:35:55 2017 rev:5 rq:456887 version:1.4.16 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-yesod-auth/ghc-yesod-auth.changes 2016-11-02 12:45:35.000000000 +0100 +++ /work/SRC/openSUSE:Factory/.ghc-yesod-auth.new/ghc-yesod-auth.changes 2017-03-16 09:35:56.202315823 +0100 @@ -1,0 +2,15 @@ +Sun Feb 5 19:32:29 UTC 2017 - psimons@suse.com + +- Update to version 1.4.16 with cabal2obs. + +------------------------------------------------------------------- +Fri Dec 16 17:46:29 UTC 2016 - psimons@suse.com + +- Update to version 1.4.15 with cabal2obs. + +------------------------------------------------------------------- +Sun Dec 4 19:47:52 UTC 2016 - psimons@suse.com + +- Update to version 1.4.14 with cabal2obs. + +------------------------------------------------------------------- Old: ---- yesod-auth-1.4.13.5.tar.gz New: ---- yesod-auth-1.4.16.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-yesod-auth.spec ++++++ --- /var/tmp/diff_new_pack.rBlxuT/_old 2017-03-16 09:35:56.690246735 +0100 +++ /var/tmp/diff_new_pack.rBlxuT/_new 2017-03-16 09:35:56.694246168 +0100 @@ -1,7 +1,7 @@ # # spec file for package ghc-yesod-auth # -# Copyright (c) 2016 SUSE LINUX GmbH, Nuernberg, Germany. +# Copyright (c) 2017 SUSE LINUX GmbH, Nuernberg, Germany. # # All modifications and additions to the file contributed by third parties # remain the property of their copyright owners, unless otherwise agreed @@ -18,7 +18,7 @@ %global pkg_name yesod-auth Name: ghc-%{pkg_name} -Version: 1.4.13.5 +Version: 1.4.16 Release: 0 Summary: Authentication for Yesod License: MIT ++++++ yesod-auth-1.4.13.5.tar.gz -> yesod-auth-1.4.16.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/yesod-auth-1.4.13.5/ChangeLog.md new/yesod-auth-1.4.16/ChangeLog.md --- old/yesod-auth-1.4.13.5/ChangeLog.md 2016-09-02 11:39:08.000000000 +0200 +++ new/yesod-auth-1.4.16/ChangeLog.md 2017-02-02 06:54:23.000000000 +0100 @@ -1,3 +1,18 @@ +## 1.4.16 + +* Fix email provider [#1330](https://github.com/yesodweb/yesod/issues/1330) + +## 1.4.15 + +* Add JSON endpoints to Yesod.Auth.Email module +* Export croatianMessage from Message module +* Minor Haddock rendering fixes at Auth.Email module + +## 1.4.14 + +* Remove Google OpenID link [#1309](https://github.com/yesodweb/yesod/pull/1309) +* Add CSRF Security check in `registerHelperFunction` [#1302](https://github.com/yesodweb/yesod/pull/1302) + ## 1.4.13.5 * Translation fix diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/yesod-auth-1.4.13.5/Yesod/Auth/Email.hs new/yesod-auth-1.4.16/Yesod/Auth/Email.hs --- old/yesod-auth-1.4.13.5/Yesod/Auth/Email.hs 2016-09-02 11:39:08.000000000 +0200 +++ new/yesod-auth-1.4.16/Yesod/Auth/Email.hs 2017-02-03 06:23:23.000000000 +0100 @@ -4,23 +4,84 @@ {-# LANGUAGE PatternGuards #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables#-} {-# LANGUAGE TypeFamilies #-} -- | A Yesod plugin for Authentication via e-mail -- --- This plugin works out of the box by only setting a few methods on the type class --- that tell the plugin how to interoprate with your user data storage (your database). --- However, almost everything is customizeable by setting more methods on the type class. --- In addition, you can send all the form submissions via JSON and completely control the user's flow. +-- This plugin works out of the box by only setting a few methods on +-- the type class that tell the plugin how to interoperate with your +-- user data storage (your database). However, almost everything is +-- customizeable by setting more methods on the type class. In +-- addition, you can send all the form submissions via JSON and +-- completely control the user's flow. +-- -- This is a standard registration e-mail flow -- --- 1) A user registers a new e-mail address, and an e-mail is sent there --- 2) The user clicks on the registration link in the e-mail --- Note that at this point they are actually logged in (without a password) --- That means that when they log out they will need to reset their password --- 3) The user sets their password and is redirected to the site. --- 4) The user can now --- * logout and sign in --- * reset their password +-- 1. A user registers a new e-mail address, and an e-mail is sent there +-- 2. The user clicks on the registration link in the e-mail. Note that +-- at this point they are actually logged in (without a +-- password). That means that when they log out they will need to +-- reset their password. +-- 3. The user sets their password and is redirected to the site. +-- 4. The user can now +-- +-- * logout and sign in +-- * reset their password +-- +-- = Using JSON Endpoints +-- +-- We are assuming that you have declared auth route as follows +-- +-- @ +-- /auth AuthR Auth getAuth +-- @ +-- +-- If you are using a different route, then you have to adjust the +-- endpoints accordingly. +-- +-- * Registration +-- +-- @ +-- Endpoint: \/auth\/page\/email\/register +-- Method: POST +-- JSON Data: { "email": "myemail@domain.com" } +-- @ +-- +-- * Forgot password +-- +-- @ +-- Endpoint: \/auth\/page\/email\/forgot-password +-- Method: POST +-- JSON Data: { "email": "myemail@domain.com" } +-- @ +-- +-- * Login +-- +-- @ +-- Endpoint: \/auth\/page\/email\/login +-- Method: POST +-- JSON Data: { +-- "email": "myemail@domain.com", +-- "password": "myStrongPassword" +-- } +-- @ +-- +-- * Set new password +-- +-- @ +-- Endpoint: \/auth\/page\/email\/set-password +-- Method: POST +-- JSON Data: { +-- "new": "newPassword", +-- "confirm": "newPassword", +-- "current": "currentPassword" +-- } +-- @ +-- +-- Note that in the set password endpoint, the presence of the key +-- "current" is dependent on how the 'needOldPassword' is defined in +-- the instance for 'YesodAuthEmail'. + module Yesod.Auth.Email ( -- * Plugin authEmail @@ -70,7 +131,9 @@ import Safe (readMay) import System.IO.Unsafe (unsafePerformIO) import qualified Text.Email.Validate - +import Network.HTTP.Types.Status (status400) +import Data.Aeson.Types (Parser(..), Result(..), parseMaybe, withObject, (.:?)) +import Data.Maybe (isJust, isNothing, fromJust) loginR, registerR, forgotPasswordR, setpassR :: AuthRoute loginR = PluginR "email" ["login"] @@ -80,7 +143,7 @@ -- | -- --- Since 1.4.5 +-- @since 1.4.5 verifyR :: Text -> Text -> AuthRoute -- FIXME verifyR eid verkey = PluginR "email" ["verify", eid, verkey] @@ -95,7 +158,7 @@ -- -- Note that any of these other identifiers must not be valid email addresses. -- --- Since 1.2.0 +-- @since 1.2.0 type Identifier = Text -- | Data stored in a database for each e-mail address. @@ -122,22 +185,22 @@ -- | Add a new email address to the database, but indicate that the address -- has not yet been verified. -- - -- Since 1.1.0 + -- @since 1.1.0 addUnverified :: Email -> VerKey -> HandlerT site IO (AuthEmailId site) -- | Send an email to the given address to verify ownership. -- - -- Since 1.1.0 + -- @since 1.1.0 sendVerifyEmail :: Email -> VerKey -> VerUrl -> HandlerT site IO () -- | Get the verification key for the given email ID. -- - -- Since 1.1.0 + -- @since 1.1.0 getVerifyKey :: AuthEmailId site -> HandlerT site IO (Maybe VerKey) -- | Set the verification key for the given email ID. -- - -- Since 1.1.0 + -- @since 1.1.0 setVerifyKey :: AuthEmailId site -> VerKey -> HandlerT site IO () -- | Verify the email address on the given account. @@ -148,39 +211,39 @@ -- -- See https://github.com/yesodweb/yesod/issues/1222. -- - -- Since 1.1.0 + -- @since 1.1.0 verifyAccount :: AuthEmailId site -> HandlerT site IO (Maybe (AuthId site)) -- | Get the salted password for the given account. -- - -- Since 1.1.0 + -- @since 1.1.0 getPassword :: AuthId site -> HandlerT site IO (Maybe SaltedPass) -- | Set the salted password for the given account. -- - -- Since 1.1.0 + -- @since 1.1.0 setPassword :: AuthId site -> SaltedPass -> HandlerT site IO () -- | Get the credentials for the given @Identifier@, which may be either an -- email address or some other identification (e.g., username). -- - -- Since 1.2.0 + -- @since 1.2.0 getEmailCreds :: Identifier -> HandlerT site IO (Maybe (EmailCreds site)) -- | Get the email address for the given email ID. -- - -- Since 1.1.0 + -- @since 1.1.0 getEmail :: AuthEmailId site -> HandlerT site IO (Maybe Email) -- | Generate a random alphanumeric string. -- - -- Since 1.1.0 - randomKey :: site -> IO Text + -- @since 1.1.0 + randomKey :: site -> IO VerKey randomKey _ = Nonce.nonce128urlT defaultNonceGen -- | Route to send user to after password has been set correctly. -- - -- Since 1.2.0 + -- @since 1.2.0 afterPasswordRoute :: site -> Route site -- | Does the user need to provide the current password in order to set a @@ -188,7 +251,7 @@ -- -- Default: if the user logged in via an email link do not require a password. -- - -- Since 1.2.1 + -- @since 1.2.1 needOldPassword :: AuthId site -> HandlerT site IO Bool needOldPassword aid' = do mkey <- lookupSession loginLinkKey @@ -208,7 +271,7 @@ -- | Response after sending a confirmation email. -- - -- Since 1.2.2 + -- @since 1.2.2 confirmationEmailSentResponse :: Text -> HandlerT site IO TypedContent confirmationEmailSentResponse identifier = do mr <- getMessageRender @@ -224,7 +287,7 @@ -- -- Default: Lower case the email address. -- - -- Since 1.2.3 + -- @since 1.2.3 normalizeEmailAddress :: site -> Text -> Text normalizeEmailAddress _ = TS.toLower @@ -234,7 +297,7 @@ -- -- Default: 'defaultRegisterHandler'. -- - -- Since: 1.2.6. + -- @since: 1.2.6 registerHandler :: AuthHandler site Html registerHandler = defaultRegisterHandler @@ -244,7 +307,7 @@ -- -- Default: 'defaultForgotPasswordHandler'. -- - -- Since: 1.2.6. + -- @since: 1.2.6 forgotPasswordHandler :: AuthHandler site Html forgotPasswordHandler = defaultForgotPasswordHandler @@ -254,7 +317,7 @@ -- -- Default: 'defaultSetPasswordHandler'. -- - -- Since: 1.2.6. + -- @since: 1.2.6 setPasswordHandler :: Bool -- ^ Whether the old password is needed. If @True@, a @@ -341,7 +404,7 @@ return $ renderAuthMessage master langs msg -- | Default implementation of 'registerHandler'. -- --- Since: 1.2.6 +-- @since 1.2.6 defaultRegisterHandler :: YesodAuthEmail master => AuthHandler master Html defaultRegisterHandler = do (widget, enctype) <- lift $ generateFormPost registrationForm @@ -377,25 +440,36 @@ return (userRes, widget) +parseEmail :: Value -> Parser Text +parseEmail = withObject "email" (\obj -> do + email' <- obj .: "email" + return email') + registerHelper :: YesodAuthEmail master => Bool -- ^ allow usernames? -> Route Auth -> HandlerT Auth (HandlerT master IO) TypedContent registerHelper allowUsername dest = do y <- lift getYesod - midentifier <- lookupPostParam "email" + checkCsrfHeaderOrParam defaultCsrfHeaderName defaultCsrfParamName + pidentifier <- lookupPostParam "email" + midentifier <- case pidentifier of + Nothing -> do + (jidentifier :: Result Value) <- lift parseCheckJsonBody + case jidentifier of + Error _ -> return Nothing + Success val -> return $ parseMaybe parseEmail val + Just _ -> return pidentifier let eidentifier = case midentifier of - Nothing -> Left Msg.NoIdentifierProvided - 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 - + Nothing -> Left Msg.NoIdentifierProvided + 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 case eidentifier of - Left route -> loginErrorMessageI dest route - Right identifier -> do - + Left route -> loginErrorMessageI dest route + Right identifier -> do mecreds <- lift $ getEmailCreds identifier registerCreds <- case mecreds of @@ -427,7 +501,7 @@ -- | Default implementation of 'forgotPasswordHandler'. -- --- Since: 1.2.6 +-- @since 1.2.6 defaultForgotPasswordHandler :: YesodAuthEmail master => AuthHandler master Html defaultForgotPasswordHandler = do (widget, enctype) <- lift $ generateFormPost forgotPasswordForm @@ -499,38 +573,56 @@ |] +parseCreds :: Value -> Parser (Text, Text) +parseCreds = withObject "creds" (\obj -> do + email' <- obj .: "email" + pass <- obj .: "password" + return (email', pass)) + + postLoginR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent postLoginR = do - (identifier, pass) <- lift $ runInputPost $ (,) + result <- lift $ runInputPostResult $ (,) <$> ireq textField "email" <*> ireq textField "password" - mecreds <- lift $ getEmailCreds identifier - maid <- - case ( mecreds >>= emailCredsAuthId - , emailCredsEmail <$> mecreds - , emailCredsStatus <$> mecreds - ) of - (Just aid, Just email, Just True) -> do - mrealpass <- lift $ getPassword aid - case mrealpass of - Nothing -> return Nothing - Just realpass -> return $ - if isValidPass pass realpass - then Just email - else Nothing - _ -> return Nothing - let isEmail = Text.Email.Validate.isValid $ encodeUtf8 identifier - case maid of - Just email -> - lift $ setCredsRedirect $ Creds - (if isEmail then "email" else "username") - email - [("verifiedEmail", email)] - Nothing -> - loginErrorMessageI LoginR $ - if isEmail - then Msg.InvalidEmailPass - else Msg.InvalidUsernamePass + + midentifier <- case result of + FormSuccess (iden, pass) -> return $ Just (iden, pass) + _ -> do + (creds :: Result Value) <- lift parseCheckJsonBody + case creds of + Error _ -> return Nothing + Success val -> return $ parseMaybe parseCreds val + + case midentifier of + Nothing -> loginErrorMessageI LoginR Msg.NoIdentifierProvided + Just (identifier, pass) -> do + mecreds <- lift $ getEmailCreds identifier + maid <- + case ( mecreds >>= emailCredsAuthId + , emailCredsEmail <$> mecreds + , emailCredsStatus <$> mecreds + ) of + (Just aid, Just email, Just True) -> do + mrealpass <- lift $ getPassword aid + case mrealpass of + Nothing -> return Nothing + Just realpass -> return $ if isValidPass pass realpass + then Just email + else Nothing + _ -> return Nothing + let isEmail = Text.Email.Validate.isValid $ encodeUtf8 identifier + case maid of + Just email -> + lift $ setCredsRedirect $ Creds + (if isEmail then "email" else "username") + email + [("verifiedEmail", email)] + Nothing -> + loginErrorMessageI LoginR $ + if isEmail + then Msg.InvalidEmailPass + else Msg.InvalidUsernamePass getPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent getPasswordR = do @@ -543,7 +635,7 @@ -- | Default implementation of 'setPasswordHandler'. -- --- Since: 1.2.6 +-- @since 1.2.6 defaultSetPasswordHandler :: YesodAuthEmail master => Bool -> AuthHandler master TypedContent defaultSetPasswordHandler needOld = do messageRender <- lift getMessageRender @@ -616,54 +708,81 @@ fsAttrs = [("autofocus", "")] } - +parsePassword :: Value -> Parser (Text, Text, Maybe Text) +parsePassword = withObject "password" (\obj -> do + email' <- obj .: "new" + pass <- obj .: "confirm" + curr <- obj .:? "current" + return (email', pass, curr)) postPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent postPasswordR = do maid <- lift maybeAuthId + (creds :: Result Value) <- lift parseCheckJsonBody + let jcreds = case creds of + Error _ -> Nothing + Success val -> parseMaybe parsePassword val + let doJsonParsing = isJust jcreds case maid of Nothing -> loginErrorMessageI LoginR Msg.BadSetPass Just aid -> do tm <- getRouteToParent - needOld <- lift $ needOldPassword aid - if not needOld then confirmPassword aid tm else do - current <- lift $ runInputPost $ ireq textField "current" + if not needOld then confirmPassword aid tm jcreds else do + res <- lift $ runInputPostResult $ ireq textField "current" + let fcurrent = case res of + FormSuccess currentPass -> Just currentPass + _ -> Nothing + let current = if doJsonParsing + then getThird jcreds + else fcurrent mrealpass <- lift $ getPassword aid case mrealpass of Nothing -> lift $ loginErrorMessage (tm setpassR) "You do not currently have a password set on your account" Just realpass - | isValidPass current realpass -> confirmPassword aid tm + | isNothing current -> loginErrorMessageI LoginR Msg.BadSetPass + | isValidPass (fromJust current) realpass -> confirmPassword aid tm jcreds | otherwise -> lift $ loginErrorMessage (tm setpassR) "Invalid current password, please try again" where msgOk = Msg.PassUpdated - confirmPassword aid tm = do - (new, confirm) <- lift $ runInputPost $ (,) + getThird (Just (_,_,t)) = t + getThird Nothing = Nothing + getNewConfirm (Just (a,b,_)) = Just (a,b) + getNewConfirm _ = Nothing + confirmPassword aid tm jcreds = do + res <- lift $ runInputPostResult $ (,) <$> ireq textField "new" <*> ireq textField "confirm" - - if new /= confirm - then loginErrorMessageI setpassR Msg.PassMismatch - else do - isSecure <- lift $ checkPasswordSecurity aid new - case isSecure of + let creds = if (isJust jcreds) + then getNewConfirm jcreds + else case res of + FormSuccess res' -> Just res' + _ -> Nothing + case creds of + Nothing -> loginErrorMessageI setpassR Msg.PassMismatch + Just (new, confirm) -> + if new /= confirm + then loginErrorMessageI setpassR Msg.PassMismatch + else do + isSecure <- lift $ checkPasswordSecurity aid new + case isSecure of Left e -> lift $ loginErrorMessage (tm setpassR) e Right () -> do - salted <- liftIO $ saltPass new - y <- lift $ do - setPassword aid salted - deleteSession loginLinkKey - addMessageI "success" msgOk - getYesod - - mr <- lift getMessageRender - selectRep $ do - provideRep $ - fmap asHtml $ lift $ redirect $ afterPasswordRoute y - provideJsonMessage (mr msgOk) + salted <- liftIO $ saltPass new + y <- lift $ do + setPassword aid salted + deleteSession loginLinkKey + addMessageI "success" msgOk + getYesod + + mr <- lift getMessageRender + selectRep $ do + provideRep $ + fmap asHtml $ lift $ redirect $ afterPasswordRoute y + provideJsonMessage (mr msgOk) saltLength :: Int saltLength = 5 @@ -697,19 +816,20 @@ -- | Session variable set when user logged in via a login link. See -- 'needOldPassword'. -- --- Since 1.2.1 +-- @since 1.2.1 loginLinkKey :: Text loginLinkKey = "_AUTH_EMAIL_LOGIN_LINK" -- | Set 'loginLinkKey' to the current time. -- --- Since 1.2.1 +-- @since 1.2.1 setLoginLinkKey :: (YesodAuthEmail site, MonadHandler m, HandlerSite m ~ site) => AuthId site -> m () setLoginLinkKey aid = do now <- liftIO getCurrentTime setSession loginLinkKey $ TS.pack $ show (toPathPiece aid, now) - +-- See https://github.com/yesodweb/yesod/issues/1245 for discussion on this +-- use of unsafePerformIO. defaultNonceGen :: Nonce.Generator defaultNonceGen = unsafePerformIO (Nonce.new) {-# NOINLINE defaultNonceGen #-} diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/yesod-auth-1.4.13.5/Yesod/Auth/GoogleEmail2.hs new/yesod-auth-1.4.16/Yesod/Auth/GoogleEmail2.hs --- old/yesod-auth-1.4.13.5/Yesod/Auth/GoogleEmail2.hs 2016-09-02 11:39:08.000000000 +0200 +++ new/yesod-auth-1.4.16/Yesod/Auth/GoogleEmail2.hs 2017-02-03 06:23:23.000000000 +0100 @@ -574,6 +574,8 @@ allPersonInfo _ = [] +-- See https://github.com/yesodweb/yesod/issues/1245 for discussion on this +-- use of unsafePerformIO. defaultNonceGen :: Nonce.Generator defaultNonceGen = unsafePerformIO (Nonce.new) {-# NOINLINE defaultNonceGen #-} diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/yesod-auth-1.4.13.5/Yesod/Auth/Message.hs new/yesod-auth-1.4.16/Yesod/Auth/Message.hs --- old/yesod-auth-1.4.13.5/Yesod/Auth/Message.hs 2016-09-02 11:39:08.000000000 +0200 +++ new/yesod-auth-1.4.16/Yesod/Auth/Message.hs 2017-02-03 06:23:23.000000000 +0100 @@ -13,6 +13,7 @@ , japaneseMessage , finnishMessage , chineseMessage + , croatianMessage , spanishMessage , czechMessage , russianMessage diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/yesod-auth-1.4.13.5/Yesod/Auth/OpenId.hs new/yesod-auth-1.4.16/Yesod/Auth/OpenId.hs --- old/yesod-auth-1.4.13.5/Yesod/Auth/OpenId.hs 2016-09-02 11:39:08.000000000 +0200 +++ new/yesod-auth-1.4.16/Yesod/Auth/OpenId.hs 2016-11-29 12:42:55.000000000 +0100 @@ -50,9 +50,6 @@ [whamlet| $newline never <form method="get" action="@{tm forwardUrl}"> - <input type="hidden" name="openid_identifier" value="https://www.google.com/accounts/o8/id"> -
participants (1)
-
root@hilbertn.suse.de