yesod-auth 1.4.16 → 1.4.17
raw patch · 9 files changed
+107/−74 lines, 9 filesdep ~persistentdep ~persistent-template
Dependency ranges changed: persistent, persistent-template
Files
- ChangeLog.md +8/−0
- Yesod/Auth.hs +3/−3
- Yesod/Auth/Email.hs +45/−26
- Yesod/Auth/GoogleEmail.hs +1/−1
- Yesod/Auth/GoogleEmail2.hs +44/−24
- Yesod/Auth/Hardcoded.hs +2/−2
- Yesod/Auth/Message.hs +2/−2
- Yesod/PasswordStore.hs +1/−15
- yesod-auth.cabal +1/−1
ChangeLog.md view
@@ -1,6 +1,14 @@+## 1.4.17++* Add Show instance for user credentials `Creds`+* Export pid type for identifying plugin+* Fix warnings+* Allow for a custom Email Login DOM with `emailLoginHandler`+ ## 1.4.16 * Fix email provider [#1330](https://github.com/yesodweb/yesod/issues/1330)+* Document JSON endpoints of Yesod.Auth.Email ## 1.4.15
Yesod/Auth.hs view
@@ -105,7 +105,7 @@ { credsPlugin :: Text -- ^ How the user was authenticated , credsIdent :: Text -- ^ Identifier. Exact meaning depends on plugin. , credsExtra :: [(Text, Text)]- }+ } deriving (Show) class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage) => YesodAuth master where type AuthId master@@ -167,7 +167,7 @@ -- > lift $ redirect HomeR -- or any other Handler code you want -- > defaultLoginHandler -- - loginHandler :: AuthHandler master Html+ loginHandler :: HandlerT Auth (HandlerT master IO) Html loginHandler = defaultLoginHandler -- | Used for i18n of messages provided by this package.@@ -227,7 +227,7 @@ -- This is an experimental API that is not broadly used throughout the yesod-auth code base runHttpRequest :: Request -> (Response BodyReader -> HandlerT master IO a) -> HandlerT master IO a runHttpRequest req inner = do- man <- authHttpManager <$> getYesod+ man <- authHttpManager Control.Applicative.<$> getYesod HandlerT $ \t -> withResponse req man $ \res -> unHandlerT (inner res) t {-# MINIMAL loginDest, logoutDest, (authenticate | getAuthId), authPlugins, authHttpManager #-}
Yesod/Auth/Email.hs view
@@ -106,6 +106,7 @@ , loginLinkKey , setLoginLinkKey -- * Default handlers+ , defaultEmailLoginHandler , defaultRegisterHandler , defaultForgotPasswordHandler , defaultSetPasswordHandler@@ -131,8 +132,7 @@ 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.Aeson.Types (Parser, Result(..), parseMaybe, withObject, (.:?)) import Data.Maybe (isJust, isNothing, fromJust) loginR, registerR, forgotPasswordR, setpassR :: AuthRoute@@ -170,10 +170,10 @@ , emailCredsEmail :: Email } -data ForgotPasswordForm = ForgotPasswordForm { forgotEmail :: Text }-data PasswordForm = PasswordForm { passwordCurrent :: Text, passwordNew :: Text, passwordConfirm :: Text }-data UserForm = UserForm { email :: Text }-data UserLoginForm = UserLoginForm { loginEmail :: Text, loginPassword :: Text }+data ForgotPasswordForm = ForgotPasswordForm { _forgotEmail :: Text }+data PasswordForm = PasswordForm { _passwordCurrent :: Text, _passwordNew :: Text, _passwordConfirm :: Text }+data UserForm = UserForm { _userFormEmail :: Text }+data UserLoginForm = UserLoginForm { _loginEmail :: Text, _loginPassword :: Text } class ( YesodAuth site , PathPiece (AuthEmailId site)@@ -291,6 +291,17 @@ normalizeEmailAddress :: site -> Text -> Text normalizeEmailAddress _ = TS.toLower + -- | Handler called to render the login page.+ -- The default works fine, but you may want to override it in+ -- order to have a different DOM.+ --+ -- Default: 'defaultEmailLoginHandler'.+ --+ -- @since 1.4.17+ emailLoginHandler :: (Route Auth -> Route site) -> WidgetT site IO ()+ emailLoginHandler = defaultEmailLoginHandler++ -- | Handler called to render the registration page. The -- default works fine, but you may want to override it in -- order to have a different DOM.@@ -298,7 +309,7 @@ -- Default: 'defaultRegisterHandler'. -- -- @since: 1.2.6- registerHandler :: AuthHandler site Html+ registerHandler :: HandlerT Auth (HandlerT site IO) Html registerHandler = defaultRegisterHandler -- | Handler called to render the \"forgot password\" page.@@ -308,7 +319,7 @@ -- Default: 'defaultForgotPasswordHandler'. -- -- @since: 1.2.6- forgotPasswordHandler :: AuthHandler site Html+ forgotPasswordHandler :: HandlerT Auth (HandlerT site IO) Html forgotPasswordHandler = defaultForgotPasswordHandler -- | Handler called to render the \"set password\" page. The@@ -324,7 +335,7 @@ -- field for the old password should be presented. -- Otherwise, just two fields for the new password are -- needed.- -> AuthHandler site TypedContent+ -> HandlerT Auth (HandlerT site IO) TypedContent setPasswordHandler = defaultSetPasswordHandler authEmail :: (YesodAuthEmail m) => AuthPlugin m@@ -347,12 +358,15 @@ getRegisterR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html getRegisterR = registerHandler -emailLoginHandler :: YesodAuthEmail master => (Route Auth -> Route master) -> WidgetT master IO ()-emailLoginHandler toParent = do+-- | Default implementation of 'emailLoginHandler'.+--+-- @since 1.4.17+defaultEmailLoginHandler :: YesodAuthEmail master => (Route Auth -> Route master) -> WidgetT master IO ()+defaultEmailLoginHandler toParent = do (widget, enctype) <- liftWidgetT $ generateFormPost loginForm [whamlet|- <form method="post" action="@{toParent loginR}">+ <form method="post" action="@{toParent loginR}", enctype=#{enctype}> <div id="emailLoginForm"> ^{widget} <div>@@ -371,7 +385,8 @@ passwordMsg <- renderMessage' Msg.Password (passwordRes, passwordView) <- mreq passwordField (passwordSettings passwordMsg) Nothing - let userRes = UserLoginForm <$> emailRes <*> passwordRes+ let userRes = UserLoginForm Control.Applicative.<$> emailRes+ Control.Applicative.<*> passwordRes let widget = do [whamlet| #{extra}@@ -402,10 +417,11 @@ langs <- languages master <- getYesod return $ renderAuthMessage master langs msg+ -- | Default implementation of 'registerHandler'. -- -- @since 1.2.6-defaultRegisterHandler :: YesodAuthEmail master => AuthHandler master Html+defaultRegisterHandler :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html defaultRegisterHandler = do (widget, enctype) <- lift $ generateFormPost registrationForm toParentRoute <- getRouteToParent@@ -502,7 +518,7 @@ -- | Default implementation of 'forgotPasswordHandler'. -- -- @since 1.2.6-defaultForgotPasswordHandler :: YesodAuthEmail master => AuthHandler master Html+defaultForgotPasswordHandler :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html defaultForgotPasswordHandler = do (widget, enctype) <- lift $ generateFormPost forgotPasswordForm toParent <- getRouteToParent@@ -518,7 +534,7 @@ where forgotPasswordForm extra = do (emailRes, emailView) <- mreq emailField emailSettings Nothing- + let forgotPasswordRes = ForgotPasswordForm <$> emailRes let widget = do [whamlet|@@ -603,21 +619,21 @@ , emailCredsEmail <$> mecreds , emailCredsStatus <$> mecreds ) of- (Just aid, Just email, Just True) -> do+ (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+ then Just email' else Nothing _ -> return Nothing let isEmail = Text.Email.Validate.isValid $ encodeUtf8 identifier case maid of- Just email ->+ Just email' -> lift $ setCredsRedirect $ Creds (if isEmail then "email" else "username")- email- [("verifiedEmail", email)]+ email'+ [("verifiedEmail", email')] Nothing -> loginErrorMessageI LoginR $ if isEmail@@ -636,22 +652,22 @@ -- | Default implementation of 'setPasswordHandler'. -- -- @since 1.2.6-defaultSetPasswordHandler :: YesodAuthEmail master => Bool -> AuthHandler master TypedContent+defaultSetPasswordHandler :: YesodAuthEmail master => Bool -> HandlerT Auth (HandlerT master IO) TypedContent defaultSetPasswordHandler needOld = do messageRender <- lift getMessageRender toParent <- getRouteToParent selectRep $ do provideJsonMessage $ messageRender Msg.SetPass provideRep $ lift $ authLayout $ do- (widget, enctype) <- liftWidgetT $ generateFormPost $ setPasswordForm needOld+ (widget, enctype) <- liftWidgetT $ generateFormPost setPasswordForm setTitleI Msg.SetPassTitle [whamlet| <h3>_{Msg.SetPass}- <form method="post" action="@{toParent setpassR}">+ <form method="post" action="@{toParent setpassR}" enctype=#{enctype}> ^{widget} |] where- setPasswordForm needOld extra = do+ setPasswordForm extra = do (currentPasswordRes, currentPasswordView) <- mreq passwordField currentPasswordSettings Nothing (newPasswordRes, newPasswordView) <- mreq passwordField newPasswordSettings Nothing (confirmPasswordRes, confirmPasswordView) <- mreq passwordField confirmPasswordSettings Nothing@@ -823,7 +839,10 @@ -- | Set 'loginLinkKey' to the current time. -- -- @since 1.2.1-setLoginLinkKey :: (YesodAuthEmail site, MonadHandler m, HandlerSite m ~ site) => AuthId site -> m ()+--setLoginLinkKey :: (MonadHandler m) => AuthId site -> m ()+setLoginLinkKey :: (MonadHandler m, YesodAuthEmail (HandlerSite m))+ => AuthId (HandlerSite m)+ -> m () setLoginLinkKey aid = do now <- liftIO getCurrentTime setSession loginLinkKey $ TS.pack $ show (toPathPiece aid, now)
Yesod/Auth/GoogleEmail.hs view
@@ -71,7 +71,7 @@ completeHelper posts dispatch _ _ = notFound -completeHelper :: YesodAuth master => [(Text, Text)] -> AuthHandler master TypedContent+completeHelper :: [(Text, Text)] -> AuthHandler master TypedContent completeHelper gets' = do master <- lift getYesod eres <- lift $ try $ OpenId.authenticateClaimed gets' (authHttpManager master)
Yesod/Auth/GoogleEmail2.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-}@@ -21,7 +22,7 @@ -- -- * Enable the Google+ API. ----- Since 1.3.1+-- @since 1.3.1 module Yesod.Auth.GoogleEmail2 ( -- * Authentication handlers authGoogleEmail@@ -45,6 +46,8 @@ , Place(..) , Email(..) , EmailType(..)+ -- * Other functions+ , pid ) where import Yesod.Auth (Auth, AuthPlugin (AuthPlugin),@@ -59,7 +62,7 @@ lift, liftIO, lookupGetParam, lookupSession, notFound, redirect, setSession, whamlet, (.:),- addMessage, getYesod, authRoute,+ addMessage, getYesod, toHtml) @@ -85,14 +88,19 @@ import Data.Text.Encoding (decodeUtf8, encodeUtf8) import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Builder as TL-import Network.HTTP.Client (Manager, parseUrl, requestHeaders,+import Network.HTTP.Client (Manager, requestHeaders, responseBody, urlEncodedBody)+import qualified Network.HTTP.Client as HTTP import Network.HTTP.Client.Conduit (Request, bodyReaderSource) import Network.HTTP.Conduit (http) import Network.HTTP.Types (renderQueryText) import System.IO.Unsafe (unsafePerformIO) +-- | Plugin identifier. This is used to identify the plugin used for+-- authentication. The 'credsPlugin' will contain this value when this+-- plugin is used for authentication.+-- @since 1.4.17 pid :: Text pid = "googleemail2" @@ -133,7 +141,7 @@ -- | An alternative version which stores user access token in the session -- variable. Use it if you want to request user's profile from your app. ----- Since 1.4.3+-- @since 1.4.3 authGoogleEmailSaveToken :: YesodAuth m => Text -- ^ client ID -> Text -- ^ client secret@@ -167,7 +175,7 @@ return $ decodeUtf8 $ toByteString $ fromByteString "https://accounts.google.com/o/oauth2/auth"- `mappend` renderQueryText True qs+ `Data.Monoid.mappend` renderQueryText True qs login tm = do [whamlet|<a href=@{tm forwardUrl}>_{Msg.LoginGoogle}|]@@ -206,7 +214,13 @@ render <- getUrlRender - req' <- liftIO $ parseUrl "https://accounts.google.com/o/oauth2/token" -- FIXME don't hardcode, use: https://accounts.google.com/.well-known/openid-configuration+ req' <- liftIO $+#if MIN_VERSION_http_client(0,4,30)+ HTTP.parseUrlThrow+#else+ HTTP.parseUrl+#endif+ "https://accounts.google.com/o/oauth2/token" -- FIXME don't hardcode, use: https://accounts.google.com/.well-known/openid-configuration let req = urlEncodedBody [ ("code", encodeUtf8 code)@@ -254,7 +268,7 @@ -- In case of parsing error returns 'Nothing'. -- Will throw 'HttpException' in case of network problems or error response code. ----- Since 1.4.3+-- @since 1.4.3 getPerson :: Manager -> Token -> HandlerT site IO (Maybe Person) getPerson manager token = parseMaybe parseJSON <$> (do req <- personValueRequest token@@ -264,7 +278,13 @@ personValueRequest :: MonadIO m => Token -> m Request personValueRequest token = do- req2' <- liftIO $ parseUrl "https://www.googleapis.com/plus/v1/people/me"+ req2' <- liftIO $+#if MIN_VERSION_http_client(0,4,30)+ HTTP.parseUrlThrow+#else+ HTTP.parseUrl+#endif+ "https://www.googleapis.com/plus/v1/people/me" return req2' { requestHeaders = [ ("Authorization", encodeUtf8 $ "Bearer " `mappend` accessToken token)@@ -277,20 +297,20 @@ -- 'authGoogleEmailSaveToken'. -- You can acquire saved token with 'getUserAccessToken'. ----- Since 1.4.3+-- @since 1.4.3 data Token = Token { accessToken :: Text , tokenType :: Text } deriving (Show, Eq) instance FromJSON Token where parseJSON = withObject "Tokens" $ \o -> Token- <$> o .: "access_token"- <*> o .: "token_type"+ Control.Applicative.<$> o .: "access_token"+ Control.Applicative.<*> o .: "token_type" -------------------------------------------------------------------------------- -- | Gender of the person ----- Since 1.4.3+-- @since 1.4.3 data Gender = Male | Female | OtherGender deriving (Show, Eq) instance FromJSON Gender where@@ -302,7 +322,7 @@ -------------------------------------------------------------------------------- -- | URIs specified in the person's profile ----- Since 1.4.3+-- @since 1.4.3 data PersonURI = PersonURI { uriLabel :: Maybe Text , uriValue :: Maybe Text@@ -317,7 +337,7 @@ -------------------------------------------------------------------------------- -- | The type of URI ----- Since 1.4.3+-- @since 1.4.3 data PersonURIType = OtherProfile -- ^ URI for another profile | Contributor -- ^ URI to a site for which this person is a contributor | Website -- ^ URI for this Google+ Page's primary website@@ -336,7 +356,7 @@ -------------------------------------------------------------------------------- -- | Current or past organizations with which this person is associated ----- Since 1.4.3+-- @since 1.4.3 data Organization = Organization { orgName :: Maybe Text -- ^ The person's job title or role within the organization@@ -363,7 +383,7 @@ -------------------------------------------------------------------------------- -- | The type of an organization ----- Since 1.4.3+-- @since 1.4.3 data OrganizationType = Work | School | OrganizationType Text -- ^ Something else@@ -377,7 +397,7 @@ -------------------------------------------------------------------------------- -- | A place where the person has lived or is living at the moment. ----- Since 1.4.3+-- @since 1.4.3 data Place = Place { -- | A place where this person has lived. For example: "Seattle, WA", "Near Toronto". placeValue :: Maybe Text@@ -391,7 +411,7 @@ -------------------------------------------------------------------------------- -- | Individual components of a name ----- Since 1.4.3+-- @since 1.4.3 data Name = Name { -- | The full name of this person, including middle names, suffixes, etc nameFormatted :: Maybe Text@@ -418,7 +438,7 @@ -------------------------------------------------------------------------------- -- | The person's relationship status. ----- Since 1.4.3+-- @since 1.4.3 data RelationshipStatus = Single -- ^ Person is single | InRelationship -- ^ Person is in a relationship | Engaged -- ^ Person is engaged@@ -447,7 +467,7 @@ -------------------------------------------------------------------------------- -- | The URI of the person's profile photo. ----- Since 1.4.3+-- @since 1.4.3 newtype PersonImage = PersonImage { imageUri :: Text } deriving (Show, Eq) instance FromJSON PersonImage where@@ -457,7 +477,7 @@ -- the image under the URI. If for some reason you need to modify the query -- part, you should do it after resizing. ----- Since 1.4.3+-- @since 1.4.3 resizePersonImage :: PersonImage -> Int -> PersonImage resizePersonImage (PersonImage uri) size = PersonImage $ uri `mappend` "?sz=" `mappend` T.pack (show size)@@ -466,7 +486,7 @@ -- | Information about the user -- Full description of the resource https://developers.google.com/+/api/latest/people ----- Since 1.4.3+-- @since 1.4.3 data Person = Person { personId :: Text -- | The name of this person, which is suitable for display@@ -536,7 +556,7 @@ -------------------------------------------------------------------------------- -- | Person's email ----- Since 1.4.3+-- @since 1.4.3 data Email = Email { emailValue :: Text , emailType :: EmailType@@ -551,7 +571,7 @@ -------------------------------------------------------------------------------- -- | Type of email ----- Since 1.4.3+-- @since 1.4.3 data EmailType = EmailAccount -- ^ Google account email address | EmailHome -- ^ Home email address | EmailWork -- ^ Work email adress
Yesod/Auth/Hardcoded.hs view
@@ -186,8 +186,8 @@ => HandlerT Auth (HandlerT master IO) TypedContent postLoginR = do (username, password) <- lift (runInputPost- ((,) <$> ireq textField "username"- <*> ireq textField "password"))+ ((,) Control.Applicative.<$> ireq textField "username"+ Control.Applicative.<*> ireq textField "password")) isValid <- lift (validatePassword username password) if isValid then lift (setCredsRedirect (Creds "hardcoded" username []))
Yesod/Auth/Message.hs view
@@ -87,7 +87,7 @@ englishMessage EnterEmail = "Enter your e-mail address below, and a confirmation e-mail will be sent to you." englishMessage ConfirmationEmailSentTitle = "Confirmation e-mail sent" englishMessage (ConfirmationEmailSent email) =- "A confirmation e-mail has been sent to " `mappend`+ "A confirmation e-mail has been sent to " `Data.Monoid.mappend` email `mappend` "." englishMessage AddressVerified = "Address verified, please set a new password"@@ -464,7 +464,7 @@ finnishMessage Email = "Sähköposti" finnishMessage UserName = "Käyttäjätunnus" -- FIXME by Google Translate "user name" finnishMessage Password = "Salasana"-finnishMessage Password = "Current password"+finnishMessage CurrentPassword = "Current password" finnishMessage Register = "Luo uusi" finnishMessage RegisterLong = "Luo uusi tili" finnishMessage EnterEmail = "Kirjoita alle sähköpostiosoitteesi, johon vahvistussähköposti lähetetään."
Yesod/PasswordStore.hs view
@@ -163,7 +163,7 @@ let hLen = 32 dkLen = hLen in go hLen dkLen where- go hLen dkLen | dkLen > (2^32 - 1) * hLen = error "Derived key too long."+ go hLen dkLen | dkLen > (2^(32 :: Int) - 1) * hLen = error "Derived key too long." | otherwise = let !l = ceiling ((fromIntegral dkLen / fromIntegral hLen) :: Double) !r = dkLen - (l - 1) * hLen@@ -412,18 +412,4 @@ x <- readSTRef ref let x' = f x x' `seq` writeSTRef ref x'-#endif--#if MIN_VERSION_bytestring(0, 10, 0)-toStrict :: BL.ByteString -> BS.ByteString-toStrict = BL.toStrict--fromStrict :: BS.ByteString -> BL.ByteString-fromStrict = BL.fromStrict-#else-toStrict :: BL.ByteString -> BS.ByteString-toStrict = BS.concat . BL.toChunks--fromStrict :: BS.ByteString -> BL.ByteString-fromStrict = BL.fromChunks . return #endif
yesod-auth.cabal view
@@ -1,5 +1,5 @@ name: yesod-auth-version: 1.4.16+version: 1.4.17 license: MIT license-file: LICENSE author: Michael Snoyman, Patrick Brisbin