yesod-auth 1.4.21 → 1.6.12.1
raw patch · 15 files changed
Files
- ChangeLog.md +119/−0
- README.md +2/−1
- Yesod/Auth.hs +153/−120
- Yesod/Auth/BrowserId.hs +11/−9
- Yesod/Auth/Dummy.hs +53/−8
- Yesod/Auth/Email.hs +327/−202
- Yesod/Auth/GoogleEmail.hs +0/−89
- Yesod/Auth/GoogleEmail2.hs +105/−94
- Yesod/Auth/Hardcoded.hs +23/−23
- Yesod/Auth/Message.hs +106/−22
- Yesod/Auth/OpenId.hs +19/−16
- Yesod/Auth/Routes.hs +5/−3
- Yesod/Auth/Rpxnow.hs +11/−7
- Yesod/Auth/Util/PasswordStore.hs +17/−24
- yesod-auth.cabal +36/−40
ChangeLog.md view
@@ -1,3 +1,122 @@+# ChangeLog for yesod-auth++## 1.6.12.1++* Support `yesod-core` 1.7++## 1.6.12.0++* Add `afterPasswordRouteHandler` [#1863](https://github.com/yesodweb/yesod/pull/1863)+* Use crypton instead of cryptonite [#1838](https://github.com/yesodweb/yesod/pull/1838)+* Set `base >= 4.11` for less CPP and imports [#1876](https://github.com/yesodweb/yesod/pull/1876)+++## 1.6.11.3++* Add Romanian translation [#1809](https://github.com/yesodweb/yesod/pull/1809)++## 1.6.11.2++* Add support for aeson 2.2 [#1820](https://github.com/yesodweb/yesod/pull/1820)++## 1.6.11.1++* No star is type [#1797](https://github.com/yesodweb/yesod/pull/1797)++## 1.6.11++* Add support for aeson 2++## 1.6.10.5++* Fix German translations of AuthMessage [#1741](https://github.com/yesodweb/yesod/pull/1741)++## 1.6.10.4++* Add support for GHC 9 [#1737](https://github.com/yesodweb/yesod/pull/1737)++## 1.6.10.3++* Relax bounds for yesod-form 1.7++## 1.6.10.2++* Relax bounds for persistent 2.12++## 1.6.10.1++* Add support for Persistent 2.11 [#1701](https://github.com/yesodweb/yesod/pull/1701)++## 1.6.10++* Updated `AuthMessage` data type in `Yesod.Auth.Message` to accommodate registration flow where password is supplied initially: deprecated `AddressVerified` and split into `EmailVerifiedChangePass` and `EmailVerified`+* Fixed a bug in `getVerifyR` related to the above, where the incorrect message was displayed when password was set during registration+* Added `sendForgotPasswordEmail` to `YesodAuthEmail` typeclass, allowing for different emails for account registration vs. forgot password+* See pull request [#1662](https://github.com/yesodweb/yesod/pull/1662)++## 1.6.9++* Added `registerHelper` and `passwordResetHelper` methods to the `YesodAuthEmail` class, allowing for customizing behavior for user registration and forgot password requests [#1660](https://github.com/yesodweb/yesod/pull/1660)+* Exposed `defaultRegisterHelper` as default implementation for the above methods++## 1.6.8.1++* Email: Fix typo in `defaultEmailLoginHandler` template [#1605](https://github.com/yesodweb/yesod/pull/1605)+* Remove unnecessary deriving of Typeable++## 1.6.8++* Dummy: Add support for JSON submissions [#1619](https://github.com/yesodweb/yesod/pull/1619)++## 1.6.7++* Redirect behavior of `clearCreds` depends on request type [#1598](https://github.com/yesodweb/yesod/pull/1598)++## 1.6.6++* Deprecated `Yesod.Auth.GoogleEmail2`, see [#1579](https://github.com/yesodweb/yesod/issues/1579) and [migration blog post](https://pbrisbin.com/posts/googleemail2_deprecation/)++## 1.6.5++* Add support for persistent 2.9 [#1516](https://github.com/yesodweb/yesod/pull/1516), [#1561](https://github.com/yesodweb/yesod/pull/1561)++## 1.6.4.1++* Email: Fix forgot-password endpoint [#1537](https://github.com/yesodweb/yesod/pull/1537)++## 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)++## 1.6.2++* Remove MINIMAL praggma for authHttpManager [#1489](https://github.com/yesodweb/yesod/issues/1489)++## 1.6.1++* Relax a number of type signatures [#1488](https://github.com/yesodweb/yesod/issues/1488)++## 1.6.0++* Upgrade to yesod-core 1.6.0+ ## 1.4.21 * Add redirectToCurrent to Yesod.Auth module for controlling setUltDestCurrent in redirectLogin [#1461](https://github.com/yesodweb/yesod/pull/1461)
README.md view
@@ -6,6 +6,7 @@ from Hackage as well. If you've written such an add-on, please notify me so that it can be added to this description. +* [yesod-auth-oauth2](https://hackage.haskell.org/package/yesod-auth-oauth2): Library to authenticate with OAuth 2.0. * [yesod-auth-account](http://hackage.haskell.org/package/yesod-auth-account): An account authentication plugin for Yesod * [yesod-auth-hashdb](http://www.stackage.org/package/yesod-auth-hashdb): The HashDB module previously packaged in yesod-auth, now with stronger, but compatible, security.-* [yesod-auth-bcrypt](https://github.com/ollieh/yesod-auth-bcrypt/): An alternative to the HashDB module.+* [yesod-auth-bcrypt](https://hackage.haskell.org/package/yesod-auth-bcrypt): An alternative to the HashDB module.
Yesod/Auth.hs view
@@ -1,16 +1,18 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-}+ module Yesod.Auth ( -- * Subsite Auth@@ -39,6 +41,7 @@ -- * Exception , AuthException (..) -- * Helper+ , MonadAuthHandler , AuthHandler -- * Internal , credsKey@@ -47,12 +50,10 @@ , asHtml ) where -import Control.Applicative ((<$>)) import Control.Monad (when) import Control.Monad.Trans.Maybe import Yesod.Auth.Routes-import Data.Aeson hiding (json) import Data.Text.Encoding (decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode) import Data.Text (Text)@@ -60,11 +61,11 @@ import qualified Data.HashMap.Lazy as Map import Data.Monoid (Endo) import Network.HTTP.Client (Manager, Request, withResponse, Response, BodyReader)+import Network.HTTP.Client.TLS (getGlobalManager) import qualified Network.Wai as W import Yesod.Core-import Yesod.Core.Types (HandlerT(..), unHandlerT) import Yesod.Persist import Yesod.Auth.Message (AuthMessage, defaultMessage) import qualified Yesod.Auth.Message as Msg@@ -72,20 +73,21 @@ import Data.Typeable (Typeable) import Control.Exception (Exception) import Network.HTTP.Types (Status, internalServerError500, unauthorized401)-import Control.Monad.Trans.Resource (MonadResourceBase) import qualified Control.Monad.Trans.Writer as Writer import Control.Monad (void)+import Data.Kind (Type) type AuthRoute = Route Auth -type AuthHandler master a = YesodAuth master => HandlerT Auth (HandlerT master IO) a+type MonadAuthHandler master m = (MonadHandler m, YesodAuth master, master ~ HandlerSite m, Auth ~ SubHandlerSite m, MonadUnliftIO m)+type AuthHandler master a = forall m. MonadAuthHandler master m => m a type Method = Text type Piece = Text -- | The result of an authentication based on credentials ----- Since 1.4.4+-- @since 1.4.4 data AuthenticationResult master = Authenticated (AuthId master) -- ^ Authenticated successfully | UserError AuthMessage -- ^ Invalid credentials provided by user@@ -94,7 +96,7 @@ data AuthPlugin master = AuthPlugin { apName :: Text , apDispatch :: Method -> [Piece] -> AuthHandler master TypedContent- , apLogin :: (Route Auth -> Route master) -> WidgetT master IO ()+ , apLogin :: (Route Auth -> Route master) -> WidgetFor master () } getAuth :: a -> Auth@@ -111,8 +113,8 @@ type AuthId master -- | specify the layout. Uses defaultLayout by default- authLayout :: WidgetT master IO () -> HandlerT master IO Html- authLayout = defaultLayout+ authLayout :: (MonadHandler m, HandlerSite m ~ master) => WidgetFor master () -> m Html+ authLayout = liftHandler . defaultLayout -- | Default destination on successful login, if no other -- destination exists.@@ -126,8 +128,8 @@ -- -- Default implementation is in terms of @'getAuthId'@ --- -- Since: 1.4.4- authenticate :: Creds master -> HandlerT master IO (AuthenticationResult master)+ -- @since: 1.4.4+ authenticate :: (MonadHandler m, HandlerSite m ~ master) => Creds master -> m (AuthenticationResult master) authenticate creds = do muid <- getAuthId creds @@ -137,7 +139,7 @@ -- -- Default implementation is in terms of @'authenticate'@ --- getAuthId :: Creds master -> HandlerT master IO (Maybe (AuthId master))+ getAuthId :: (MonadHandler m, HandlerSite m ~ master) => Creds master -> m (Maybe (AuthId master)) getAuthId creds = do auth <- authenticate creds @@ -167,7 +169,7 @@ -- > lift $ redirect HomeR -- or any other Handler code you want -- > defaultLoginHandler --- loginHandler :: HandlerT Auth (HandlerT master IO) Html+ loginHandler :: AuthHandler master Html loginHandler = defaultLoginHandler -- | Used for i18n of messages provided by this package.@@ -184,7 +186,8 @@ -- | When being redirected to the login page should the current page -- be set to redirect back to. Default is 'True'.- -- @since 1.4.18+ --+ -- @since 1.4.21 redirectToCurrent :: master -> Bool redirectToCurrent _ = True @@ -192,15 +195,16 @@ -- type. This allows backends to reuse persistent connections. If none of -- the backends you're using use HTTP connections, you can safely return -- @error \"authHttpManager\"@ here.- authHttpManager :: master -> Manager+ authHttpManager :: (MonadHandler m, HandlerSite m ~ master) => m Manager+ authHttpManager = liftIO getGlobalManager -- | Called on a successful login. By default, calls -- @addMessageI "success" NowLoggedIn@.- onLogin :: HandlerT master IO ()+ onLogin :: (MonadHandler m, master ~ HandlerSite m) => m () onLogin = addMessageI "success" Msg.NowLoggedIn -- | Called on logout. By default, does nothing- onLogout :: HandlerT master IO ()+ onLogout :: (MonadHandler m, master ~ HandlerSite m) => m () onLogout = return () -- | Retrieves user credentials, if user is authenticated.@@ -211,17 +215,17 @@ -- especially useful for creating an API to be accessed via some means -- other than a browser. --- -- Since 1.2.0- maybeAuthId :: HandlerT master IO (Maybe (AuthId master))+ -- @since 1.2.0+ maybeAuthId :: (MonadHandler m, master ~ HandlerSite m) => m (Maybe (AuthId master)) default maybeAuthId- :: (YesodAuthPersist master, Typeable (AuthEntity master))- => HandlerT master IO (Maybe (AuthId master))+ :: (MonadHandler m, master ~ HandlerSite m, YesodAuthPersist master, Typeable (AuthEntity master))+ => m (Maybe (AuthId master)) maybeAuthId = defaultMaybeAuthId -- | Called on login error for HTTP requests. By default, calls -- @addMessage@ with "error" as status and redirects to @dest@.- onErrorHtml :: (MonadResourceBase m) => Route master -> Text -> HandlerT master m Html+ onErrorHtml :: (MonadHandler m, HandlerSite m ~ master) => Route master -> Text -> m Html onErrorHtml dest msg = do addMessage "error" $ toHtml msg fmap asHtml $ redirect dest@@ -231,18 +235,22 @@ -- -- The HTTP 'Request' is given in case it is useful to change behavior based on inspecting the request. -- 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+ :: (MonadHandler m, HandlerSite m ~ master, MonadUnliftIO m)+ => Request+ -> (Response BodyReader -> m a)+ -> m a runHttpRequest req inner = do- man <- authHttpManager Control.Applicative.<$> getYesod- HandlerT $ \t -> withResponse req man $ \res -> unHandlerT (inner res) t+ man <- authHttpManager+ withRunInIO $ \run -> withResponse req man $ run . inner - {-# MINIMAL loginDest, logoutDest, (authenticate | getAuthId), authPlugins, authHttpManager #-}+ {-# MINIMAL loginDest, logoutDest, (authenticate | getAuthId), authPlugins #-} {-# DEPRECATED getAuthId "Define 'authenticate' instead; 'getAuthId' will be removed in the next major version" #-} -- | Internal session key used to hold the authentication information. ----- Since 1.2.3+-- @since 1.2.3 credsKey :: Text credsKey = "_ID" @@ -252,10 +260,10 @@ -- 'maybeAuthIdRaw' for more information. The first call in a request -- does a database request to make sure that the account is still in the database. ----- Since 1.1.2+-- @since 1.1.2 defaultMaybeAuthId- :: (YesodAuthPersist master, Typeable (AuthEntity master))- => HandlerT master IO (Maybe (AuthId master))+ :: (MonadHandler m, HandlerSite m ~ master, YesodAuthPersist master, Typeable (AuthEntity master))+ => m (Maybe (AuthId master)) defaultMaybeAuthId = runMaybeT $ do s <- MaybeT $ lookupSession credsKey aid <- MaybeT $ return $ fromPathPiece s@@ -263,8 +271,13 @@ return aid cachedAuth- :: (YesodAuthPersist master, Typeable (AuthEntity master))- => AuthId master -> HandlerT master IO (Maybe (AuthEntity master))+ :: ( MonadHandler m+ , YesodAuthPersist master+ , Typeable (AuthEntity master)+ , HandlerSite m ~ master+ )+ => AuthId master+ -> m (Maybe (AuthEntity master)) cachedAuth = fmap unCachedMaybeAuth . cached@@ -277,52 +290,59 @@ -- This is the default 'loginHandler'. It concatenates plugin widgets and -- wraps the result in 'authLayout'. See 'loginHandler' for more details. ----- Since 1.4.9+-- @since 1.4.9 defaultLoginHandler :: AuthHandler master Html defaultLoginHandler = do tp <- getRouteToParent- lift $ authLayout $ do+ authLayout $ do setTitleI Msg.LoginTitle master <- getYesod mapM_ (flip apLogin tp) (authPlugins master) -loginErrorMessageI :: (MonadResourceBase m, YesodAuth master)- => Route child- -> AuthMessage- -> HandlerT child (HandlerT master m) TypedContent+loginErrorMessageI+ :: Route Auth+ -> AuthMessage+ -> AuthHandler master TypedContent loginErrorMessageI dest msg = do toParent <- getRouteToParent- lift $ loginErrorMessageMasterI (toParent dest) msg+ loginErrorMessageMasterI (toParent dest) msg -loginErrorMessageMasterI :: (YesodAuth master, MonadResourceBase m, RenderMessage master AuthMessage)- => Route master- -> AuthMessage- -> HandlerT master m TypedContent+loginErrorMessageMasterI+ :: (MonadHandler m, HandlerSite m ~ master, YesodAuth master)+ => Route master+ -> AuthMessage+ -> m TypedContent loginErrorMessageMasterI dest msg = do mr <- getMessageRender loginErrorMessage dest (mr msg) -- | For HTML, set the message and redirect to the route. -- For JSON, send the message and a 401 status-loginErrorMessage :: (YesodAuth master, MonadResourceBase m)- => Route master+loginErrorMessage+ :: (MonadHandler m, YesodAuth (HandlerSite m))+ => Route (HandlerSite m) -> Text- -> HandlerT master m TypedContent+ -> m TypedContent loginErrorMessage dest msg = messageJson401 msg (onErrorHtml dest msg) -messageJson401 :: MonadResourceBase m => Text -> HandlerT master m Html -> HandlerT master m TypedContent+messageJson401+ :: MonadHandler m+ => Text+ -> m Html+ -> m TypedContent messageJson401 = messageJsonStatus unauthorized401 -messageJson500 :: MonadResourceBase m => Text -> HandlerT master m Html -> HandlerT master m TypedContent+messageJson500 :: MonadHandler m => Text -> m Html -> m TypedContent messageJson500 = messageJsonStatus internalServerError500 -messageJsonStatus :: MonadResourceBase m- => Status- -> Text- -> HandlerT master m Html- -> HandlerT master m TypedContent+messageJsonStatus+ :: MonadHandler m+ => Status+ -> Text+ -> m Html+ -> m TypedContent messageJsonStatus status msg html = selectRep $ do provideRep html provideRep $ do@@ -334,9 +354,10 @@ provideJsonMessage msg = provideRep $ return $ object ["message" .= msg] -setCredsRedirect :: YesodAuth master- => Creds master -- ^ new credentials- -> HandlerT master IO TypedContent+setCredsRedirect+ :: (MonadHandler m, YesodAuth (HandlerSite m))+ => Creds (HandlerSite m) -- ^ new credentials+ -> m TypedContent setCredsRedirect creds = do y <- getYesod auth <- authenticate creds@@ -375,10 +396,10 @@ return $ renderAuthMessage master langs msg -- | Sets user credentials for the session after checking them with authentication backends.-setCreds :: YesodAuth master- => Bool -- ^ if HTTP redirects should be done- -> Creds master -- ^ new credentials- -> HandlerT master IO ()+setCreds :: (MonadHandler m, YesodAuth (HandlerSite m))+ => Bool -- ^ if HTTP redirects should be done+ -> Creds (HandlerSite m) -- ^ new credentials+ -> m () setCreds doRedirects creds = if doRedirects then void $ setCredsRedirect creds@@ -388,29 +409,36 @@ _ -> return () -- | same as defaultLayoutJson, but uses authLayout-authLayoutJson :: (YesodAuth site, ToJSON j)- => WidgetT site IO () -- ^ HTML- -> HandlerT site IO j -- ^ JSON- -> HandlerT site IO TypedContent+authLayoutJson+ :: (ToJSON j, MonadAuthHandler master m)+ => WidgetFor master () -- ^ HTML+ -> m j -- ^ JSON+ -> m TypedContent authLayoutJson w json = selectRep $ do provideRep $ authLayout w provideRep $ fmap toJSON json -- | Clears current user credentials for the session. ----- Since 1.1.7-clearCreds :: YesodAuth master- => Bool -- ^ if HTTP redirect to 'logoutDest' should be done- -> HandlerT master IO ()+-- @since 1.1.7+clearCreds :: (MonadHandler m, YesodAuth (HandlerSite m))+ => Bool -- ^ if HTTP, redirect to 'logoutDest'+ -> m () clearCreds doRedirects = do- y <- getYesod onLogout deleteSession credsKey- when doRedirects $ do- redirectUltDest $ logoutDest y+ y <- getYesod+ aj <- acceptsJson+ case (aj, doRedirects) of+ (True, _) -> sendResponse successfulLogout+ (False, True) -> redirectUltDest (logoutDest y)+ _ -> return ()+ where successfulLogout = object ["message" .= msg]+ msg :: Text+ msg = "Logged out successfully!" getCheckR :: AuthHandler master TypedContent-getCheckR = lift $ do+getCheckR = do creds <- maybeAuthId authLayoutJson (do setTitle "Authentication Status"@@ -426,12 +454,12 @@ <p>Not logged in. |] jsonCreds creds =- Object $ Map.fromList+ toJSON $ Map.fromList [ (T.pack "logged_in", Bool $ maybe False (const True) creds) ] -setUltDestReferer' :: AuthHandler master ()-setUltDestReferer' = lift $ do+setUltDestReferer' :: (MonadHandler m, YesodAuth (HandlerSite m)) => m ()+setUltDestReferer' = do master <- getYesod when (redirectToReferer master) setUltDestReferer @@ -439,14 +467,16 @@ getLoginR = setUltDestReferer' >> loginHandler getLogoutR :: AuthHandler master ()-getLogoutR = setUltDestReferer' >> redirectToPost LogoutR+getLogoutR = do+ tp <- getRouteToParent+ setUltDestReferer' >> redirectToPost (tp LogoutR) postLogoutR :: AuthHandler master ()-postLogoutR = lift $ clearCreds True+postLogoutR = clearCreds True handlePluginR :: Text -> [Text] -> AuthHandler master TypedContent handlePluginR plugin pieces = do- master <- lift getYesod+ master <- getYesod env <- waiRequest let method = decodeUtf8With lenientDecode $ W.requestMethod env case filter (\x -> apName x == plugin) (authPlugins master) of@@ -457,23 +487,28 @@ -- with the user\'s database identifier to get the value in the database. This -- assumes that you are using a Persistent database. ----- Since 1.1.0+-- @since 1.1.0 maybeAuth :: ( YesodAuthPersist master , val ~ AuthEntity master , Key val ~ AuthId master , PersistEntity val , Typeable val- ) => HandlerT master IO (Maybe (Entity val))-maybeAuth = runMaybeT $ do- (aid, ae) <- MaybeT maybeAuthPair- return $ Entity aid ae+ , MonadHandler m+ , HandlerSite m ~ master+ ) => m (Maybe (Entity val))+maybeAuth = fmap (fmap (uncurry Entity)) maybeAuthPair -- | Similar to 'maybeAuth', but doesn’t assume that you are using a -- Persistent database. ----- Since 1.4.0-maybeAuthPair :: (YesodAuthPersist master, Typeable (AuthEntity master))- => HandlerT master IO (Maybe (AuthId master, AuthEntity master))+-- @since 1.4.0+maybeAuthPair+ :: ( YesodAuthPersist master+ , Typeable (AuthEntity master)+ , MonadHandler m+ , HandlerSite m ~ master+ )+ => m (Maybe (AuthId master, AuthEntity master)) maybeAuthPair = runMaybeT $ do aid <- MaybeT maybeAuthId ae <- MaybeT $ cachedAuth aid@@ -481,7 +516,6 @@ newtype CachedMaybeAuth val = CachedMaybeAuth { unCachedMaybeAuth :: Maybe val }- deriving Typeable -- | Class which states that the given site is an instance of @YesodAuth@ -- and that its @AuthId@ is a lookup key for the full user information in@@ -492,7 +526,7 @@ -- given value. This is the common case in Yesod, and means that you can -- easily look up the full information on a given user. ----- Since 1.4.0+-- @since 1.4.0 class (YesodAuth master, YesodPersist master) => YesodAuthPersist master where -- | If the @AuthId@ for a given site is a persistent ID, this will give the -- value for that entity. E.g.:@@ -500,31 +534,23 @@ -- > type AuthId MySite = UserId -- > AuthEntity MySite ~ User --- -- Since 1.2.0- type AuthEntity master :: *+ -- @since 1.2.0+ type AuthEntity master :: Type type AuthEntity master = KeyEntity (AuthId master) - getAuthEntity :: AuthId master -> HandlerT master IO (Maybe (AuthEntity master))+ getAuthEntity :: (MonadHandler m, HandlerSite m ~ master)+ => AuthId master -> m (Maybe (AuthEntity master)) -#if MIN_VERSION_persistent(2,5,0) default getAuthEntity :: ( YesodPersistBackend master ~ backend , PersistRecordBackend (AuthEntity master) backend , Key (AuthEntity master) ~ AuthId master , PersistStore backend- )- => AuthId master -> HandlerT master IO (Maybe (AuthEntity master))-#else- default getAuthEntity- :: ( YesodPersistBackend master- ~ PersistEntityBackend (AuthEntity master)- , Key (AuthEntity master) ~ AuthId master- , PersistStore (YesodPersistBackend master)- , PersistEntity (AuthEntity master)+ , MonadHandler m+ , HandlerSite m ~ master )- => AuthId master -> HandlerT master IO (Maybe (AuthEntity master))-#endif- getAuthEntity = runDB . get+ => AuthId master -> m (Maybe (AuthEntity master))+ getAuthEntity = liftHandler . runDB . get type family KeyEntity key@@ -533,36 +559,43 @@ -- | Similar to 'maybeAuthId', but redirects to a login page if user is not -- authenticated or responds with error 401 if this is an API client (expecting JSON). ----- Since 1.1.0-requireAuthId :: YesodAuth master => HandlerT master IO (AuthId master)+-- @since 1.1.0+requireAuthId :: (MonadHandler m, YesodAuth (HandlerSite m)) => m (AuthId (HandlerSite m)) requireAuthId = maybeAuthId >>= maybe handleAuthLack return -- | Similar to 'maybeAuth', but redirects to a login page if user is not -- authenticated or responds with error 401 if this is an API client (expecting JSON). ----- Since 1.1.0+-- @since 1.1.0 requireAuth :: ( YesodAuthPersist master , val ~ AuthEntity master , Key val ~ AuthId master , PersistEntity val , Typeable val- ) => HandlerT master IO (Entity val)+ , MonadHandler m+ , HandlerSite m ~ master+ ) => m (Entity val) requireAuth = maybeAuth >>= maybe handleAuthLack return -- | Similar to 'requireAuth', but not tied to Persistent's 'Entity' type. -- Instead, the 'AuthId' and 'AuthEntity' are returned in a tuple. ----- Since 1.4.0-requireAuthPair :: (YesodAuthPersist master, Typeable (AuthEntity master))- => HandlerT master IO (AuthId master, AuthEntity master)+-- @since 1.4.0+requireAuthPair+ :: ( YesodAuthPersist master+ , Typeable (AuthEntity master)+ , MonadHandler m+ , HandlerSite m ~ master+ )+ => m (AuthId master, AuthEntity master) requireAuthPair = maybeAuthPair >>= maybe handleAuthLack return -handleAuthLack :: YesodAuth master => HandlerT master IO a+handleAuthLack :: (YesodAuth (HandlerSite m), MonadHandler m) => m a handleAuthLack = do aj <- acceptsJson if aj then notAuthenticated else redirectLogin -redirectLogin :: YesodAuth master => HandlerT master IO a+redirectLogin :: (YesodAuth (HandlerSite m), MonadHandler m) => m a redirectLogin = do y <- getYesod when (redirectToCurrent y) setUltDestCurrent@@ -574,10 +607,10 @@ renderMessage = renderAuthMessage data AuthException = InvalidFacebookResponse- deriving (Show, Typeable)+ deriving Show instance Exception AuthException -instance YesodAuth master => YesodSubDispatch Auth (HandlerT master IO) where+instance YesodAuth master => YesodSubDispatch Auth master where yesodSubDispatch = $(mkYesodSubDispatch resourcesAuth) asHtml :: Html -> Html
Yesod/Auth/BrowserId.hs view
@@ -1,7 +1,8 @@-{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+ -- | NOTE: Mozilla Persona will be shut down by the end of 2016, therefore this -- module is no longer recommended for use. module Yesod.Auth.BrowserId@@ -70,20 +71,21 @@ , apDispatch = \m ps -> case (m, ps) of ("GET", [assertion]) -> do- master <- lift getYesod audience <- case bisAudience of Just a -> return a Nothing -> do r <- getUrlRender- return $ T.takeWhile (/= '/') $ stripScheme $ r LoginR- memail <- lift $ checkAssertion audience assertion (authHttpManager master)+ tm <- getRouteToParent+ return $ T.takeWhile (/= '/') $ stripScheme $ r $ tm LoginR+ manager <- authHttpManager+ memail <- checkAssertion audience assertion manager case memail of Nothing -> do $logErrorS "yesod-auth" "BrowserID assertion failure" tm <- getRouteToParent- lift $ loginErrorMessage (tm LoginR) "BrowserID login error."- Just email -> lift $ setCredsRedirect Creds+ loginErrorMessage (tm LoginR) "BrowserID login error."+ Just email -> setCredsRedirect Creds { credsPlugin = pid , credsIdent = email , credsExtra = []@@ -116,7 +118,7 @@ createOnClickOverride :: BrowserIdSettings -> (Route Auth -> Route master) -> Maybe (Route master)- -> WidgetT master IO Text+ -> WidgetFor master Text createOnClickOverride BrowserIdSettings {..} toMaster mOnRegistration = do unless bisLazyLoad $ addScriptRemote browserIdJs onclick <- newIdent@@ -165,5 +167,5 @@ -- name. createOnClick :: BrowserIdSettings -> (Route Auth -> Route master)- -> WidgetT master IO Text+ -> WidgetFor master Text createOnClick bidSettings toMaster = createOnClickOverride bidSettings toMaster Nothing
Yesod/Auth/Dummy.hs view
@@ -1,23 +1,68 @@-{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+ -- | Provides a dummy authentication module that simply lets a user specify--- his/her identifier. This is not intended for real world use, just for--- testing.+-- their identifier. This is not intended for real world use, just for+-- testing. This plugin supports form submissions via JSON (since 1.6.8).+--+-- = Using the JSON Login Endpoint+--+-- We are assuming that you have declared `authRoute` as follows+--+-- @+-- Just $ AuthR LoginR+-- @+--+-- If you are using a different one, then you have to adjust the+-- endpoint accordingly.+--+-- @+-- Endpoint: \/auth\/page\/dummy+-- Method: POST+-- JSON Data: {+-- "ident": "my identifier"+-- }+-- @+--+-- Remember to add the following headers:+--+-- - Accept: application\/json+-- - Content-Type: application\/json+ module Yesod.Auth.Dummy ( authDummy ) where -import Yesod.Auth-import Yesod.Form (runInputPost, textField, ireq)-import Yesod.Core+import Data.Aeson.Types (Parser, Result (..))+import qualified Data.Aeson.Types as A (parseEither, withObject)+import Data.Text (Text)+import Yesod.Auth+import Yesod.Core+import Yesod.Form (ireq, runInputPost, textField) +identParser :: Value -> Parser Text+identParser = A.withObject "Ident" (.: "ident")+ authDummy :: YesodAuth m => AuthPlugin m authDummy = AuthPlugin "dummy" dispatch login where+ dispatch :: Text -> [Text] -> AuthHandler m TypedContent dispatch "POST" [] = do- ident <- lift $ runInputPost $ ireq textField "ident"- lift $ setCredsRedirect $ Creds "dummy" ident []+ (jsonResult :: Result Value) <- parseCheckJsonBody+ eIdent <- case jsonResult of+ Success val -> return $ A.parseEither identParser val+ Error err -> return $ Left err+ case eIdent of+ Right ident ->+ setCredsRedirect $ Creds "dummy" ident []+ Left _ -> do+ ident <- runInputPost $ ireq textField "ident"+ setCredsRedirect $ Creds "dummy" ident [] dispatch _ _ = notFound url = PluginR "dummy" [] login authToMaster = do
Yesod/Auth/Email.hs view
@@ -1,11 +1,12 @@ {-# LANGUAGE ConstrainedClassMethods #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PatternGuards #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# 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@@ -31,24 +32,27 @@ -- = 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" }+-- JSON Data: {+-- "email": "myemail@domain.com",+-- "password": "myStrongPassword" (optional)+-- } -- @--- +-- -- * Forgot password--- +-- -- @ -- Endpoint: \/auth\/page\/email\/forgot-password -- Method: POST@@ -56,16 +60,16 @@ -- @ -- -- * Login--- +-- -- @ -- Endpoint: \/auth\/page\/email\/login -- Method: POST--- JSON Data: { +-- JSON Data: { -- "email": "myemail@domain.com", -- "password": "myStrongPassword" -- } -- @--- +-- -- * Set new password -- -- @@@ -110,30 +114,32 @@ , defaultRegisterHandler , defaultForgotPasswordHandler , defaultSetPasswordHandler+ -- * Default helpers+ , defaultRegisterHelper ) where +import qualified Crypto.Hash as H+import qualified Crypto.Nonce as Nonce+import Data.Aeson.Types (Parser, Result (..), parseMaybe,+ withObject, (.:?))+import Data.ByteArray (convert)+import Data.ByteString.Base16 as B16+import Data.Maybe (isJust)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text as TS+import Data.Text.Encoding (decodeUtf8With, encodeUtf8)+import qualified Data.Text.Encoding as TE+import Data.Text.Encoding.Error (lenientDecode)+import Data.Time (addUTCTime, getCurrentTime)+import Safe (readMay)+import System.IO.Unsafe (unsafePerformIO)+import qualified Text.Email.Validate import Yesod.Auth-import qualified Yesod.Auth.Message as Msg+import qualified Yesod.Auth.Message as Msg+import qualified Yesod.Auth.Util.PasswordStore as PS import Yesod.Core import Yesod.Form-import qualified Yesod.Auth.Util.PasswordStore as PS-import Control.Applicative ((<$>), (<*>))-import qualified Crypto.Hash as H-import qualified Crypto.Nonce as Nonce-import Data.ByteString.Base16 as B16-import Data.Text (Text)-import qualified Data.Text as TS-import qualified Data.Text as T-import Data.Text.Encoding (decodeUtf8With, encodeUtf8)-import qualified Data.Text.Encoding as TE-import Data.Text.Encoding.Error (lenientDecode)-import Data.Time (addUTCTime, getCurrentTime)-import Safe (readMay)-import System.IO.Unsafe (unsafePerformIO)-import qualified Text.Email.Validate-import Data.Aeson.Types (Parser, Result(..), parseMaybe, withObject, (.:?))-import Data.Maybe (isJust)-import Data.ByteArray (convert) loginR, registerR, forgotPasswordR, setpassR :: AuthRoute loginR = PluginR "email" ["login"]@@ -141,11 +147,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@@ -186,37 +196,59 @@ -- has not yet been verified. -- -- @since 1.1.0- addUnverified :: Email -> VerKey -> HandlerT site IO (AuthEmailId site)+ 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- sendVerifyEmail :: Email -> VerKey -> VerUrl -> HandlerT site IO ()+ sendVerifyEmail :: Email -> VerKey -> VerUrl -> AuthHandler site () + -- | Send an email to the given address to re-verify ownership in the case of+ -- a password reset. This can be used to send a different email when a user+ -- goes through the 'forgot password' flow as opposed to the 'account registration'+ -- flow.+ --+ -- Default: Will call 'sendVerifyEmail', resulting in the same email getting sent+ -- for both registrations and password resets.+ --+ -- @since 1.6.10+ sendForgotPasswordEmail :: Email -> VerKey -> VerUrl -> AuthHandler site ()+ sendForgotPasswordEmail = sendVerifyEmail+ -- | Get the verification key for the given email ID. -- -- @since 1.1.0- getVerifyKey :: AuthEmailId site -> HandlerT site IO (Maybe VerKey)+ getVerifyKey :: AuthEmailId site -> AuthHandler site (Maybe VerKey) -- | Set the verification key for the given email ID. -- -- @since 1.1.0- setVerifyKey :: AuthEmailId site -> VerKey -> HandlerT site IO ()+ setVerifyKey :: AuthEmailId site -> VerKey -> AuthHandler site () -- | Hash and salt a password -- -- Default: 'saltPass'. -- -- @since 1.4.20- hashAndSaltPassword :: Text -> HandlerT site IO SaltedPass- hashAndSaltPassword = liftIO . saltPass+ hashAndSaltPassword :: Text -> AuthHandler site SaltedPass+ hashAndSaltPassword password = liftIO $ saltPass password -- | Verify a password matches the stored password for the given account. -- -- Default: Fetch a password with 'getPassword' and match using 'Yesod.Auth.Util.PasswordStore.verifyPassword'. -- -- @since 1.4.20- verifyPassword :: Text -> SaltedPass -> HandlerT site IO Bool+ verifyPassword :: Text -> SaltedPass -> AuthHandler site Bool verifyPassword plain salted = return $ isValidPass plain salted -- | Verify the email address on the given account.@@ -228,28 +260,28 @@ -- See <https://github.com/yesodweb/yesod/issues/1222>. -- -- @since 1.1.0- verifyAccount :: AuthEmailId site -> HandlerT site IO (Maybe (AuthId site))+ verifyAccount :: AuthEmailId site -> AuthHandler site (Maybe (AuthId site)) -- | Get the salted password for the given account. -- -- @since 1.1.0- getPassword :: AuthId site -> HandlerT site IO (Maybe SaltedPass)+ getPassword :: AuthId site -> AuthHandler site (Maybe SaltedPass) -- | Set the salted password for the given account. -- -- @since 1.1.0- setPassword :: AuthId site -> SaltedPass -> HandlerT site IO ()+ setPassword :: AuthId site -> SaltedPass -> AuthHandler site () -- | 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- getEmailCreds :: Identifier -> HandlerT site IO (Maybe (EmailCreds site))+ getEmailCreds :: Identifier -> AuthHandler site (Maybe (EmailCreds site)) -- | Get the email address for the given email ID. -- -- @since 1.1.0- getEmail :: AuthEmailId site -> HandlerT site IO (Maybe Email)+ getEmail :: AuthEmailId site -> AuthHandler site (Maybe Email) -- | Generate a random alphanumeric string. --@@ -262,13 +294,27 @@ -- @since 1.2.0 afterPasswordRoute :: site -> Route site + -- | Same as @afterPasswordRoute@ but allows you to run Handler code+ --+ -- If this function is overridden then @afterPasswordRoute@ is ignored.+ --+ -- @since 1.6.12.0+ afterPasswordRouteHandler :: AuthHandler site (Route site)+ afterPasswordRouteHandler = getYesod >>= pure . afterPasswordRoute++ -- | 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? -- -- Default: if the user logged in via an email link do not require a password. -- -- @since 1.2.1- needOldPassword :: AuthId site -> HandlerT site IO Bool+ needOldPassword :: AuthId site -> AuthHandler site Bool needOldPassword aid' = do mkey <- lookupSession loginLinkKey case mkey >>= readMay . TS.unpack of@@ -280,7 +326,7 @@ -- | Check that the given plain-text password meets minimum security standards. -- -- Default: password is at least three characters.- checkPasswordSecurity :: AuthId site -> Text -> HandlerT site IO (Either Text ())+ checkPasswordSecurity :: AuthId site -> Text -> AuthHandler site (Either Text ()) checkPasswordSecurity _ x | TS.length x >= 3 = return $ Right () | otherwise = return $ Left "Password must be at least three characters"@@ -288,7 +334,7 @@ -- | Response after sending a confirmation email. -- -- @since 1.2.2- confirmationEmailSentResponse :: Text -> HandlerT site IO TypedContent+ confirmationEmailSentResponse :: Text -> AuthHandler site TypedContent confirmationEmailSentResponse identifier = do mr <- getMessageRender selectRep $ do@@ -299,6 +345,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.@@ -314,7 +368,7 @@ -- Default: 'defaultEmailLoginHandler'. -- -- @since 1.4.17- emailLoginHandler :: (Route Auth -> Route site) -> WidgetT site IO ()+ emailLoginHandler :: (Route Auth -> Route site) -> WidgetFor site () emailLoginHandler = defaultEmailLoginHandler @@ -325,7 +379,7 @@ -- Default: 'defaultRegisterHandler'. -- -- @since: 1.2.6- registerHandler :: HandlerT Auth (HandlerT site IO) Html+ registerHandler :: AuthHandler site Html registerHandler = defaultRegisterHandler -- | Handler called to render the \"forgot password\" page.@@ -335,7 +389,7 @@ -- Default: 'defaultForgotPasswordHandler'. -- -- @since: 1.2.6- forgotPasswordHandler :: HandlerT Auth (HandlerT site IO) Html+ forgotPasswordHandler :: AuthHandler site Html forgotPasswordHandler = defaultForgotPasswordHandler -- | Handler called to render the \"set password\" page. The@@ -351,38 +405,75 @@ -- field for the old password should be presented. -- Otherwise, just two fields for the new password are -- needed.- -> HandlerT Auth (HandlerT site IO) TypedContent+ -> AuthHandler site TypedContent setPasswordHandler = defaultSetPasswordHandler ++ -- | Helper that controls what happens after a user registration+ -- request is submitted. This method can be overridden to completely+ -- customize what happens during the user registration process,+ -- such as for handling additional fields in the registration form.+ --+ -- The default implementation is in terms of 'defaultRegisterHelper'.+ --+ -- @since: 1.6.9+ registerHelper :: Route Auth+ -- ^ Where to sent the user in the event+ -- that registration fails+ -> AuthHandler site TypedContent+ registerHelper = defaultRegisterHelper False False++ -- | Helper that controls what happens after a forgot password+ -- request is submitted. As with `registerHelper`, this method can+ -- be overridden to customize the behavior when a user attempts+ -- to recover their password.+ --+ -- The default implementation is in terms of 'defaultRegisterHelper'.+ --+ -- @since: 1.6.9+ passwordResetHelper :: Route Auth+ -- ^ Where to sent the user in the event+ -- that the password reset fails+ -> AuthHandler site TypedContent+ passwordResetHelper = defaultRegisterHelper True True+ authEmail :: (YesodAuthEmail m) => AuthPlugin m authEmail = AuthPlugin "email" dispatch emailLoginHandler where+ dispatch :: YesodAuthEmail m => Text -> [Text] -> AuthHandler m TypedContent dispatch "GET" ["register"] = getRegisterR >>= sendResponse dispatch "POST" ["register"] = postRegisterR >>= sendResponse dispatch "GET" ["forgot-password"] = getForgotPasswordR >>= sendResponse dispatch "POST" ["forgot-password"] = postForgotPasswordR >>= sendResponse dispatch "GET" ["verify", eid, verkey] = case fromPathPiece eid of+ Nothing -> notFound+ Just eid' -> getVerifyR eid' verkey False >>= sendResponse+ dispatch "GET" ["verify", eid, verkey, hasSetPass] =+ case fromPathPiece eid of Nothing -> notFound- Just eid' -> getVerifyR eid' verkey >>= sendResponse+ 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 dispatch _ _ = notFound -getRegisterR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html+getRegisterR :: YesodAuthEmail master => AuthHandler master Html getRegisterR = registerHandler -- | Default implementation of 'emailLoginHandler'. -- -- @since 1.4.17-defaultEmailLoginHandler :: YesodAuthEmail master => (Route Auth -> Route master) -> WidgetT master IO ()+defaultEmailLoginHandler+ :: YesodAuthEmail master+ => (Route Auth -> Route master)+ -> WidgetFor master () defaultEmailLoginHandler toParent = do- (widget, enctype) <- liftWidgetT $ generateFormPost loginForm+ (widget, enctype) <- generateFormPost loginForm [whamlet|- <form method="post" action="@{toParent loginR}", enctype=#{enctype}>+ <form method="post" action="@{toParent loginR}" enctype=#{enctype}> <div id="emailLoginForm"> ^{widget} <div>@@ -401,16 +492,15 @@ passwordMsg <- renderMessage' Msg.Password (passwordRes, passwordView) <- mreq passwordField (passwordSettings passwordMsg) Nothing - let userRes = UserLoginForm Control.Applicative.<$> emailRes- Control.Applicative.<*> passwordRes+ let userRes = UserLoginForm <$> emailRes <*> passwordRes let widget = do- [whamlet|- #{extra}- <div>- ^{fvInput emailView}- <div>- ^{fvInput passwordView}- |]+ [whamlet|+ #{extra}+ <div>+ ^{fvInput emailView}+ <div>+ ^{fvInput passwordView}+ |] return (userRes, widget) emailSettings emailMsg = do@@ -437,11 +527,11 @@ -- | Default implementation of 'registerHandler'. -- -- @since 1.2.6-defaultRegisterHandler :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html+defaultRegisterHandler :: YesodAuthEmail master => AuthHandler master Html defaultRegisterHandler = do- (widget, enctype) <- lift $ generateFormPost registrationForm+ (widget, enctype) <- generateFormPost registrationForm toParentRoute <- getRouteToParent- lift $ authLayout $ do+ authLayout $ do setTitleI Msg.RegisterLong [whamlet| <p>_{Msg.EnterEmail}@@ -464,81 +554,106 @@ let userRes = UserForm <$> emailRes let widget = do- [whamlet|- #{extra}- ^{fvLabel emailView}- ^{fvInput emailView}- |]+ [whamlet|+ #{extra}+ ^{fvLabel emailView}+ ^{fvInput emailView}+ |] 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?- -> Route Auth- -> HandlerT Auth (HandlerT master IO) TypedContent-registerHelper allowUsername dest = do- y <- lift getYesod+defaultRegisterHelper :: YesodAuthEmail master+ => Bool -- ^ Allow lookup via username in addition to email+ -> Bool -- ^ Set to `True` for forgot password flow, `False` for new account registration+ -> Route Auth+ -> AuthHandler master TypedContent+defaultRegisterHelper allowUsername forgotPassword dest = do+ y <- getYesod 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+ 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 (forgotPassword, creds) of+ (False, Just (_, mp)) -> mp+ _ -> Nothing+ case eidentifier of- Left route -> loginErrorMessageI dest route+ Left failMsg -> loginErrorMessageI dest failMsg Right identifier -> do- mecreds <- lift $ getEmailCreds identifier+ 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- lift $ setVerifyKey lid key- return $ Just (lid, key, email)+ setVerifyKey lid key+ return $ Just (lid, verStatus, key, email) Nothing | allowUsername -> return Nothing | otherwise -> do key <- liftIO $ randomKey y- lid <- lift $ 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- let verUrl = render $ verifyR (toPathPiece lid) verKey- lift $ sendVerifyEmail email verKey verUrl- lift $ confirmationEmailSentResponse identifier+ Just regCreds@(_, False, _, _) -> sendConfirmationEmail regCreds+ Just regCreds@(_, True, _, _) -> do+ if forgotPassword+ then sendConfirmationEmail regCreds+ else case emailPreviouslyRegisteredResponse identifier of+ Just response -> response+ Nothing -> sendConfirmationEmail regCreds+ where sendConfirmationEmail (lid, _, verKey, email) = do+ render <- getUrlRender+ tp <- getRouteToParent+ let verUrl = render $ tp $ verifyR (toPathPiece lid) verKey (isJust mpass)+ if forgotPassword+ then sendForgotPasswordEmail email verKey verUrl+ else sendVerifyEmail email verKey verUrl+ confirmationEmailSentResponse identifier -postRegisterR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent-postRegisterR = registerHelper False registerR -getForgotPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html+postRegisterR :: YesodAuthEmail master => AuthHandler master TypedContent+postRegisterR = registerHelper registerR++getForgotPasswordR :: YesodAuthEmail master => AuthHandler master Html getForgotPasswordR = forgotPasswordHandler -- | Default implementation of 'forgotPasswordHandler'. -- -- @since 1.2.6-defaultForgotPasswordHandler :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html+defaultForgotPasswordHandler :: YesodAuthEmail master => AuthHandler master Html defaultForgotPasswordHandler = do- (widget, enctype) <- lift $ generateFormPost forgotPasswordForm+ (widget, enctype) <- generateFormPost forgotPasswordForm toParent <- getRouteToParent- lift $ authLayout $ do+ authLayout $ do setTitleI Msg.PasswordResetTitle [whamlet| <p>_{Msg.PasswordResetPrompt}@@ -553,11 +668,11 @@ let forgotPasswordRes = ForgotPasswordForm <$> emailRes let widget = do- [whamlet|- #{extra}- ^{fvLabel emailView}- ^{fvInput emailView}- |]+ [whamlet|+ #{extra}+ ^{fvLabel emailView}+ ^{fvInput emailView}+ |] return (forgotPasswordRes, widget) emailSettings =@@ -569,35 +684,45 @@ fsAttrs = [("autofocus", "")] } -postForgotPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent-postForgotPasswordR = registerHelper True forgotPasswordR+postForgotPasswordR :: YesodAuthEmail master => AuthHandler master TypedContent+postForgotPasswordR = passwordResetHelper forgotPasswordR getVerifyR :: YesodAuthEmail site => AuthEmailId site -> Text- -> HandlerT Auth (HandlerT site IO) TypedContent-getVerifyR lid key = do- realKey <- lift $ getVerifyKey lid- memail <- lift $ getEmail lid- mr <- lift getMessageRender+ -> Bool+ -> AuthHandler site TypedContent+getVerifyR lid key hasSetPass = do+ realKey <- getVerifyKey lid+ memail <- getEmail lid+ mr <- getMessageRender case (realKey == Just key, memail) of (True, Just email) -> do- muid <- lift $ verifyAccount lid+ muid <- verifyAccount lid case muid of Nothing -> invalidKey mr Just uid -> do- lift $ setCreds False $ Creds "email-verify" email [("verifiedEmail", email)] -- FIXME uid?- lift $ setLoginLinkKey uid- let msgAv = Msg.AddressVerified+ setCreds False $ Creds "email-verify" email [("verifiedEmail", email)] -- FIXME uid?+ setLoginLinkKey uid+ let msgAv = if hasSetPass+ then Msg.EmailVerified+ else Msg.EmailVerifiedChangePass selectRep $ do provideRep $ do- lift $ addMessageI "success" msgAv- fmap asHtml $ redirect setpassR+ addMessageI "success" msgAv+ 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 msgIk = Msg.InvalidKey- invalidKey mr = messageJson401 (mr msgIk) $ lift $ authLayout $ do+ invalidKey mr = messageJson401 (mr msgIk) $ authLayout $ do setTitleI msgIk [whamlet| $newline never@@ -612,35 +737,35 @@ return (email', pass)) -postLoginR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent+postLoginR :: YesodAuthEmail master => AuthHandler master TypedContent postLoginR = do- result <- lift $ runInputPostResult $ (,)+ result <- runInputPostResult $ (,) <$> ireq textField "email" <*> ireq textField "password" midentifier <- case result of FormSuccess (iden, pass) -> return $ Just (iden, pass) _ -> do- (creds :: Result Value) <- lift parseCheckJsonBody+ (creds :: Result Value) <- parseCheckJsonBody case creds of- Error _ -> return Nothing+ 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+ mecreds <- getEmailCreds identifier maid <- case ( mecreds >>= emailCredsAuthId , emailCredsEmail <$> mecreds , emailCredsStatus <$> mecreds ) of (Just aid, Just email', Just True) -> do- mrealpass <- lift $ getPassword aid+ mrealpass <- getPassword aid case mrealpass of Nothing -> return Nothing Just realpass -> do- passValid <- lift $ verifyPassword pass realpass + passValid <- verifyPassword pass realpass return $ if passValid then Just email' else Nothing@@ -648,7 +773,7 @@ let isEmail = Text.Email.Validate.isValid $ encodeUtf8 identifier case maid of Just email' ->- lift $ setCredsRedirect $ Creds+ setCredsRedirect $ Creds (if isEmail then "email" else "username") email' [("verifiedEmail", email')]@@ -658,26 +783,26 @@ then Msg.InvalidEmailPass else Msg.InvalidUsernamePass -getPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent+getPasswordR :: YesodAuthEmail master => AuthHandler master TypedContent getPasswordR = do- maid <- lift maybeAuthId+ maid <- maybeAuthId case maid of Nothing -> loginErrorMessageI LoginR Msg.BadSetPass- Just _ -> do- needOld <- maybe (return True) (lift . needOldPassword) maid+ Just aid -> do+ needOld <- needOldPassword aid setPasswordHandler needOld -- | Default implementation of 'setPasswordHandler'. -- -- @since 1.2.6-defaultSetPasswordHandler :: YesodAuthEmail master => Bool -> HandlerT Auth (HandlerT master IO) TypedContent+defaultSetPasswordHandler :: YesodAuthEmail master => Bool -> AuthHandler master TypedContent defaultSetPasswordHandler needOld = do- messageRender <- lift getMessageRender+ messageRender <- getMessageRender toParent <- getRouteToParent selectRep $ do provideJsonMessage $ messageRender Msg.SetPass- provideRep $ lift $ authLayout $ do- (widget, enctype) <- liftWidgetT $ generateFormPost setPasswordForm+ provideRep $ authLayout $ do+ (widget, enctype) <- generateFormPost setPasswordForm setTitleI Msg.SetPassTitle [whamlet| <h3>_{Msg.SetPass}@@ -692,29 +817,29 @@ let passwordFormRes = PasswordForm <$> currentPasswordRes <*> newPasswordRes <*> confirmPasswordRes let widget = do- [whamlet|- #{extra}- <table>- $if needOld- <tr>- <th>- ^{fvLabel currentPasswordView}- <td>- ^{fvInput currentPasswordView}- <tr>- <th>- ^{fvLabel newPasswordView}- <td>- ^{fvInput newPasswordView}- <tr>- <th>- ^{fvLabel confirmPasswordView}- <td>- ^{fvInput confirmPasswordView}- <tr>- <td colspan="2">- <input type=submit value=_{Msg.SetPassTitle}>- |]+ [whamlet|+ #{extra}+ <table>+ $if needOld+ <tr>+ <th>+ ^{fvLabel currentPasswordView}+ <td>+ ^{fvInput currentPasswordView}+ <tr>+ <th>+ ^{fvLabel newPasswordView}+ <td>+ ^{fvInput newPasswordView}+ <tr>+ <th>+ ^{fvLabel confirmPasswordView}+ <td>+ ^{fvInput confirmPasswordView}+ <tr>+ <td colspan="2">+ <input type=submit value=_{Msg.SetPassTitle}>+ |] return (passwordFormRes, widget) currentPasswordSettings =@@ -749,75 +874,75 @@ curr <- obj .:? "current" return (email', pass, curr)) -postPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent+postPasswordR :: YesodAuthEmail master => AuthHandler master TypedContent postPasswordR = do- maid <- lift maybeAuthId- (creds :: Result Value) <- lift parseCheckJsonBody+ maid <- maybeAuthId+ (creds :: Result Value) <- parseCheckJsonBody let jcreds = case creds of- Error _ -> Nothing+ 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+ needOld <- needOldPassword aid if not needOld then confirmPassword aid tm jcreds else do- res <- lift $ runInputPostResult $ ireq textField "current"+ res <- runInputPostResult $ ireq textField "current" let fcurrent = case res of FormSuccess currentPass -> Just currentPass- _ -> Nothing+ _ -> Nothing let current = if doJsonParsing then getThird jcreds else fcurrent- mrealpass <- lift $ getPassword aid+ mrealpass <- getPassword aid case (mrealpass, current) of (Nothing, _) ->- lift $ loginErrorMessage (tm setpassR) "You do not currently have a password set on your account"+ loginErrorMessage (tm setpassR) "You do not currently have a password set on your account" (_, Nothing) -> loginErrorMessageI LoginR Msg.BadSetPass (Just realpass, Just current') -> do- passValid <- lift $ verifyPassword current' realpass+ passValid <- verifyPassword current' realpass if passValid then confirmPassword aid tm jcreds- else lift $ loginErrorMessage (tm setpassR) "Invalid current password, please try again"+ else loginErrorMessage (tm setpassR) "Invalid current password, please try again" where msgOk = Msg.PassUpdated getThird (Just (_,_,t)) = t- getThird Nothing = Nothing+ getThird Nothing = Nothing getNewConfirm (Just (a,b,_)) = Just (a,b)- getNewConfirm _ = Nothing+ getNewConfirm _ = Nothing confirmPassword aid tm jcreds = do- res <- lift $ runInputPostResult $ (,)+ res <- runInputPostResult $ (,) <$> ireq textField "new" <*> ireq textField "confirm" let creds = if (isJust jcreds) then getNewConfirm jcreds else case res of FormSuccess res' -> Just res'- _ -> Nothing+ _ -> 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+ isSecure <- checkPasswordSecurity aid new case isSecure of- Left e -> lift $ loginErrorMessage (tm setpassR) e+ Left e -> loginErrorMessage (tm setpassR) e Right () -> do- salted <- lift $ hashAndSaltPassword new- y <- lift $ do- setPassword aid salted- deleteSession loginLinkKey- addMessageI "success" msgOk- getYesod+ salted <- hashAndSaltPassword new+ setPassword aid salted+ deleteSession loginLinkKey+ addMessageI "success" msgOk+ _ <- getYesod - mr <- lift getMessageRender+ mr <- getMessageRender selectRep $ do- provideRep $ - fmap asHtml $ lift $ redirect $ afterPasswordRoute y+ provideRep $ do+ route <- afterPasswordRouteHandler+ fmap asHtml $ redirect route provideJsonMessage (mr msgOk) saltLength :: Int
− Yesod/Auth/GoogleEmail.hs
@@ -1,89 +0,0 @@-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE RankNTypes #-}--- | Use an email address as an identifier via Google's OpenID login system.------ This backend will not use the OpenID identifier at all. It only uses OpenID--- as a login system. By using this plugin, you are trusting Google to validate--- an email address, and requiring users to have a Google account. On the plus--- side, you get to use email addresses as the identifier, many users have--- existing Google accounts, the login system has been long tested (as opposed--- to BrowserID), and it requires no credential managing or setup (as opposed--- to Email).-module Yesod.Auth.GoogleEmail- {-# DEPRECATED "Google no longer provides OpenID support, please use Yesod.Auth.GoogleEmail2" #-}- ( authGoogleEmail- , forwardUrl- ) where--import Yesod.Auth-import qualified Web.Authenticate.OpenId as OpenId--import Yesod.Core-import Data.Text (Text)-import qualified Yesod.Auth.Message as Msg-import qualified Data.Text as T-import Control.Exception.Lifted (try, SomeException)--pid :: Text-pid = "googleemail"--forwardUrl :: AuthRoute-forwardUrl = PluginR pid ["forward"]--googleIdent :: Text-googleIdent = "https://www.google.com/accounts/o8/id"--authGoogleEmail :: YesodAuth m => AuthPlugin m-authGoogleEmail =- AuthPlugin pid dispatch login- where- complete = PluginR pid ["complete"]- login tm =- [whamlet|<a href=@{tm forwardUrl}>_{Msg.LoginGoogle}|]- dispatch "GET" ["forward"] = do- render <- getUrlRender- let complete' = render complete- master <- lift getYesod- eres <- lift $ try $ OpenId.getForwardUrl googleIdent complete' Nothing- [ ("openid.ax.type.email", "http://schema.openid.net/contact/email")- , ("openid.ns.ax", "http://openid.net/srv/ax/1.0")- , ("openid.ns.ax.required", "email")- , ("openid.ax.mode", "fetch_request")- , ("openid.ax.required", "email")- , ("openid.ui.icon", "true")- ] (authHttpManager master)- either- (\err -> do- tm <- getRouteToParent- lift $ loginErrorMessage (tm LoginR) $ T.pack $ show (err :: SomeException))- redirect- eres- dispatch "GET" ["complete", ""] = dispatch "GET" ["complete"] -- compatibility issues- dispatch "GET" ["complete"] = do- rr <- getRequest- completeHelper $ reqGetParams rr- dispatch "POST" ["complete", ""] = dispatch "POST" ["complete"] -- compatibility issues- dispatch "POST" ["complete"] = do- (posts, _) <- runRequestBody- completeHelper posts- dispatch _ _ = notFound--completeHelper :: [(Text, Text)] -> AuthHandler master TypedContent-completeHelper gets' = do- master <- lift getYesod- eres <- lift $ try $ OpenId.authenticateClaimed gets' (authHttpManager master)- tm <- getRouteToParent- either (onFailure tm) (onSuccess tm) eres- where- onFailure tm err =- lift $ loginErrorMessage (tm LoginR) $ T.pack $ show (err :: SomeException)- onSuccess tm oir = do- let OpenId.Identifier ident = OpenId.oirOpLocal oir- memail <- lookupGetParam "openid.ext1.value.email"- case (memail, "https://www.google.com/accounts/o8/id" `T.isPrefixOf` ident) of- (Just email, True) -> lift $ setCredsRedirect $ Creds pid email []- (_, False) -> lift $ loginErrorMessage (tm LoginR) "Only Google login is supported"- (Nothing, _) -> lift $ loginErrorMessage (tm LoginR) "No email address provided"
Yesod/Auth/GoogleEmail2.hs view
@@ -1,7 +1,10 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+ -- | Use an email address as an identifier via Google's login system. -- -- Note that this is a replacement for "Yesod.Auth.GoogleEmail", which depends@@ -24,6 +27,7 @@ -- -- @since 1.3.1 module Yesod.Auth.GoogleEmail2+ {-# DEPRECATED "Google+ is being shut down, please migrate to Google Sign-in https://pbrisbin.com/posts/googleemail2_deprecation/" #-} ( -- * Authentication handlers authGoogleEmail , authGoogleEmailSaveToken@@ -50,57 +54,61 @@ , pid ) where -import Yesod.Auth (Auth, AuthPlugin (AuthPlugin),- AuthRoute, Creds (Creds),- Route (PluginR), YesodAuth,- runHttpRequest, setCredsRedirect,- logoutDest)-import qualified Yesod.Auth.Message as Msg-import Yesod.Core (HandlerSite, HandlerT, MonadHandler,- TypedContent, getRouteToParent,- getUrlRender, invalidArgs,- lift, liftIO, lookupGetParam,- lookupSession, notFound, redirect,- setSession, whamlet, (.:),- addMessage, getYesod,- toHtml)+import Yesod.Auth (Auth, AuthHandler,+ AuthPlugin (AuthPlugin),+ AuthRoute, Creds (Creds),+ Route (PluginR), YesodAuth,+ logoutDest, runHttpRequest,+ setCredsRedirect)+import qualified Yesod.Auth.Message as Msg+import Yesod.Core (HandlerSite, MonadHandler,+ TypedContent, addMessage,+ getRouteToParent, getUrlRender,+ getYesod, invalidArgs, liftIO,+ liftSubHandler, lookupGetParam,+ lookupSession, notFound, redirect,+ setSession, toHtml, whamlet, (.:)) -import Blaze.ByteString.Builder (fromByteString, toByteString)-import Control.Applicative ((<$>), (<*>))-import Control.Arrow (second)-import Control.Monad (unless, when)-import Control.Monad.IO.Class (MonadIO)-import qualified Crypto.Nonce as Nonce-import Data.Aeson ((.:?))-import qualified Data.Aeson as A+import Blaze.ByteString.Builder (fromByteString, toByteString)+import Control.Arrow (second)+import Control.Monad (unless, when)+import Control.Monad.IO.Class (MonadIO)+import qualified Crypto.Nonce as Nonce+import Data.Aeson ((.:?))+import qualified Data.Aeson as A #if MIN_VERSION_aeson(1,0,0)-import qualified Data.Aeson.Text as A+import qualified Data.Aeson.Text as A #else-import qualified Data.Aeson.Encode as A+import qualified Data.Aeson.Encode as A #endif-import Data.Aeson.Parser (json')-import Data.Aeson.Types (FromJSON (parseJSON), parseEither,- parseMaybe, withObject, withText)-import Data.Conduit (($$+-), ($$))-import Data.Conduit.Attoparsec (sinkParser)-import qualified Data.HashMap.Strict as M-import Data.Maybe (fromMaybe)-import Data.Monoid (mappend)-import Data.Text (Text)-import qualified Data.Text as T-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, requestHeaders,- responseBody, urlEncodedBody)-import qualified Network.HTTP.Client as HTTP+import Data.Aeson.Parser (json')+import Data.Aeson.Types (FromJSON (parseJSON), parseEither,+ parseMaybe, withObject, withText)+import Data.Conduit+import Data.Conduit.Attoparsec (sinkParser)+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import qualified Data.Text as T+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, 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)+import Network.HTTP.Conduit (http)+import Network.HTTP.Types (renderQueryText)+import System.IO.Unsafe (unsafePerformIO) +#if MIN_VERSION_aeson(2, 0, 0)+import qualified Data.Aeson.Key+import qualified Data.Aeson.KeyMap+#else+import qualified Data.HashMap.Strict as M+#endif + -- | 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.@@ -179,7 +187,7 @@ return $ decodeUtf8 $ toByteString $ fromByteString "https://accounts.google.com/o/oauth2/auth"- `Data.Monoid.mappend` renderQueryText True qs+ `mappend` renderQueryText True qs login tm = do [whamlet|<a href=@{tm forwardUrl}>_{Msg.LoginGoogle}|]@@ -187,10 +195,10 @@ dispatch :: YesodAuth site => Text -> [Text]- -> HandlerT Auth (HandlerT site IO) TypedContent+ -> AuthHandler site TypedContent dispatch "GET" ["forward"] = do tm <- getRouteToParent- lift (getDest tm) >>= redirect+ getDest tm >>= redirect dispatch "GET" ["complete"] = do mstate <- lookupGetParam "state"@@ -207,30 +215,27 @@ case merr of Nothing -> invalidArgs ["Missing code paramter"] Just err -> do- master <- lift getYesod+ master <- getYesod let msg = case err of "access_denied" -> "Access denied" _ -> "Unknown error occurred: " `T.append` err addMessage "error" $ toHtml msg- lift $ redirect $ logoutDest master+ redirect $ logoutDest master Just c -> return c render <- getUrlRender+ tm <- getRouteToParent 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) , ("client_id", encodeUtf8 clientID) , ("client_secret", encodeUtf8 clientSecret)- , ("redirect_uri", encodeUtf8 $ render complete)+ , ("redirect_uri", encodeUtf8 $ render $ tm complete) , ("grant_type", "authorization_code") ] req'@@ -239,7 +244,7 @@ value <- makeHttpRequest req token@(Token accessToken' tokenType') <- case parseEither parseJSON value of- Left e -> error e+ Left e -> error e Right t -> return t unless (tokenType' == "Bearer") $ error $ "Unknown token type: " ++ show tokenType'@@ -247,48 +252,43 @@ -- User's access token is saved for further access to API when storeToken $ setSession accessTokenKey accessToken' - personValue <- makeHttpRequest =<< personValueRequest token+ personValReq <- personValueRequest token+ personValue <- makeHttpRequest personValReq+ person <- case parseEither parseJSON personValue of- Left e -> error e+ Left e -> error e Right x -> return x email <- case map emailValue $ filter (\e -> emailType e == EmailAccount) $ personEmails person of [e] -> return e- [] -> error "No account email"- x -> error $ "Too many account emails: " ++ show x- lift $ setCredsRedirect $ Creds pid email $ allPersonInfo personValue+ [] -> error "No account email"+ x -> error $ "Too many account emails: " ++ show x+ setCredsRedirect $ Creds pid email $ allPersonInfo personValue dispatch _ _ = notFound -makeHttpRequest- :: (YesodAuth site)- => Request- -> HandlerT Auth (HandlerT site IO) A.Value-makeHttpRequest req = lift $- runHttpRequest req $ \res -> bodyReaderSource (responseBody res) $$ sinkParser json'+makeHttpRequest :: Request -> AuthHandler site A.Value+makeHttpRequest req =+ liftSubHandler $ runHttpRequest req $ \res ->+ runConduit $ bodyReaderSource (responseBody res) .| sinkParser json' -- | Allows to fetch information about a user from Google's API. -- In case of parsing error returns 'Nothing'. -- Will throw 'HttpException' in case of network problems or error response code. -- -- @since 1.4.3-getPerson :: Manager -> Token -> HandlerT site IO (Maybe Person)-getPerson manager token = parseMaybe parseJSON <$> (do+getPerson :: MonadHandler m => Manager -> Token -> m (Maybe Person)+getPerson manager token = liftSubHandler $ parseMaybe parseJSON <$> (do req <- personValueRequest token res <- http req manager- responseBody res $$+- sinkParser json'+ runConduit $ responseBody res .| sinkParser json' ) personValueRequest :: MonadIO m => Token -> m Request personValueRequest token = do- req2' <- liftIO $-#if MIN_VERSION_http_client(0,4,30)- HTTP.parseUrlThrow-#else- HTTP.parseUrl-#endif- "https://www.googleapis.com/plus/v1/people/me"+ req2' <- liftIO+ $ HTTP.parseUrlThrow "https://www.googleapis.com/plus/v1/people/me" return req2' { requestHeaders = [ ("Authorization", encodeUtf8 $ "Bearer " `mappend` accessToken token)@@ -307,9 +307,10 @@ } deriving (Show, Eq) instance FromJSON Token where- parseJSON = withObject "Tokens" $ \o -> Token- Control.Applicative.<$> o .: "access_token"- Control.Applicative.<*> o .: "token_type"+ parseJSON = withObject "Tokens" $ \o ->+ Token+ <$> o .: "access_token"+ <*> o .: "token_type" -------------------------------------------------------------------------------- -- | Gender of the person@@ -457,16 +458,16 @@ instance FromJSON RelationshipStatus where parseJSON = withText "RelationshipStatus" $ \t -> return $ case t of- "single" -> Single- "in_a_relationship" -> InRelationship- "engaged" -> Engaged- "married" -> Married- "its_complicated" -> Complicated- "open_relationship" -> OpenRelationship- "widowed" -> Widowed- "in_domestic_partnership" -> DomesticPartnership- "in_civil_union" -> CivilUnion- _ -> RelationshipStatus t+ "single" -> Single+ "in_a_relationship" -> InRelationship+ "engaged" -> Engaged+ "married" -> Married+ "its_complicated" -> Complicated+ "open_relationship" -> OpenRelationship+ "widowed" -> Widowed+ "in_domestic_partnership" -> DomesticPartnership+ "in_civil_union" -> CivilUnion+ _ -> RelationshipStatus t -------------------------------------------------------------------------------- -- | The URI of the person's profile photo.@@ -592,9 +593,19 @@ _ -> EmailType t allPersonInfo :: A.Value -> [(Text, Text)]-allPersonInfo (A.Object o) = map enc $ M.toList o- where enc (key, A.String s) = (key, s)- enc (key, v) = (key, TL.toStrict $ TL.toLazyText $ A.encodeToTextBuilder v)+allPersonInfo (A.Object o) = map enc $ mapToList o+ where+ enc (key, A.String s) = (keyToText key, s)+ enc (key, v) = (keyToText key, TL.toStrict $ TL.toLazyText $ A.encodeToTextBuilder v)++#if MIN_VERSION_aeson(2, 0, 0)+ keyToText = Data.Aeson.Key.toText+ mapToList = Data.Aeson.KeyMap.toList+#else+ keyToText = id+ mapToList = M.toList+#endif+ allPersonInfo _ = []
Yesod/Auth/Hardcoded.hs view
@@ -1,10 +1,11 @@-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+ {-| Module : Yesod.Auth.Hardcoded Description : Very simple auth plugin for hardcoded auth pairs.@@ -52,7 +53,7 @@ 'AuthId' must have an instance of 'PathPiece' class, this is needed to store user identifier in session (this happens in 'setCreds' and 'setCredsRedirect' actions) and to read that identifier from session (this happens in-`dafaultMaybeAuthId` action). So we have to define it:+`defaultMaybeAuthId` action). So we have to define it: @ import Text.Read (readMaybe)@@ -85,7 +86,7 @@ @ lookupUser :: Text -> Maybe SiteManager-lookupUser username = find (\m -> manUserName m == username) siteManagers+lookupUser username = find (\\m -> manUserName m == username) siteManagers @ @@ -113,7 +114,7 @@ validPassword :: Text -> Text -> Bool validPassword u p =- case find (\m -> manUserName m == u && manPassWord m == p) siteManagers of+ case find (\\m -> manUserName m == u && manPassWord m == p) siteManagers of Just _ -> True _ -> False @@@ -131,14 +132,12 @@ , loginR ) where -import Yesod.Auth (Auth, AuthPlugin (..), AuthRoute,+import Yesod.Auth (AuthHandler, AuthPlugin (..), AuthRoute, Creds (..), Route (..), YesodAuth, loginErrorMessageI, setCredsRedirect) import qualified Yesod.Auth.Message as Msg import Yesod.Core import Yesod.Form (ireq, runInputPost, textField)--import Control.Applicative ((<$>), (<*>)) import Data.Text (Text) @@ -148,18 +147,19 @@ class (YesodAuth site) => YesodAuthHardcoded site where -- | Check whether given user name exists among hardcoded names.- doesUserNameExist :: Text -> HandlerT site IO Bool+ doesUserNameExist :: Text -> AuthHandler site Bool -- | Validate given user name with given password.- validatePassword :: Text -> Text -> HandlerT site IO Bool+ validatePassword :: Text -> Text -> AuthHandler site Bool authHardcoded :: YesodAuthHardcoded m => AuthPlugin m authHardcoded = AuthPlugin "hardcoded" dispatch loginWidget where+ dispatch :: YesodAuthHardcoded m => Text -> [Text] -> AuthHandler m TypedContent dispatch "POST" ["login"] = postLoginR >>= sendResponse- dispatch _ _ = notFound+ dispatch _ _ = notFound loginWidget toMaster = do request <- getRequest [whamlet|@@ -182,16 +182,16 @@ |] -postLoginR :: (YesodAuthHardcoded master)- => HandlerT Auth (HandlerT master IO) TypedContent+postLoginR :: YesodAuthHardcoded site+ => AuthHandler site TypedContent postLoginR =- do (username, password) <- lift (runInputPost- ((,) Control.Applicative.<$> ireq textField "username"- Control.Applicative.<*> ireq textField "password"))- isValid <- lift (validatePassword username password)+ do (username, password) <- runInputPost+ ((,) <$> ireq textField "username"+ <*> ireq textField "password")+ isValid <- validatePassword username password if isValid- then lift (setCredsRedirect (Creds "hardcoded" username []))- else do isExists <- lift (doesUserNameExist username)+ then setCredsRedirect (Creds "hardcoded" username [])+ else do isExists <- doesUserNameExist username loginErrorMessageI LoginR (if isExists then Msg.InvalidUsernamePass
Yesod/Auth/Message.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+ module Yesod.Auth.Message ( AuthMessage (..) , defaultMessage@@ -20,10 +21,10 @@ , dutchMessage , danishMessage , koreanMessage+ , romanianMessage ) where -import Data.Monoid (mappend, (<>))-import Data.Text (Text)+import Data.Text (Text) data AuthMessage = NoOpenID@@ -40,6 +41,8 @@ | ConfirmationEmailSentTitle | ConfirmationEmailSent Text | AddressVerified+ | EmailVerifiedChangePass+ | EmailVerified | InvalidKeyTitle | InvalidKey | InvalidEmailPass@@ -69,6 +72,7 @@ | LogoutTitle | AuthError {-# DEPRECATED Logout "Please, use LogoutTitle instead." #-}+{-# DEPRECATED AddressVerified "Please, use EmailVerifiedChangePass instead." #-} -- | Defaults to 'englishMessage'. defaultMessage :: AuthMessage -> Text@@ -88,10 +92,10 @@ 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 " `Data.Monoid.mappend`- email `mappend`- "."-englishMessage AddressVerified = "Address verified, please set a new password"+ "A confirmation e-mail has been sent to " `mappend` email `mappend` "."+englishMessage AddressVerified = "Email address verified, please set a new password"+englishMessage EmailVerifiedChangePass = "Email address verified, please set a new password"+englishMessage EmailVerified = "Email address verified" englishMessage InvalidKeyTitle = "Invalid verification key" englishMessage InvalidKey = "I'm sorry, but that was an invalid verification key." englishMessage InvalidEmailPass = "Invalid email/password combination"@@ -139,6 +143,8 @@ email `mappend` "." portugueseMessage AddressVerified = "Endereço verificado, por favor entre com uma nova senha"+portugueseMessage EmailVerifiedChangePass = "Endereço verificado, por favor entre com uma nova senha"+portugueseMessage EmailVerified = "Endereço verificado" portugueseMessage InvalidKeyTitle = "Chave de verificação inválida" portugueseMessage InvalidKey = "Por favor nos desculpe, mas essa é uma chave de verificação inválida." portugueseMessage InvalidEmailPass = "E-mail e/ou senha inválidos"@@ -187,6 +193,8 @@ email `mappend` "." spanishMessage AddressVerified = "Dirección verificada, por favor introduzca una contraseña"+spanishMessage EmailVerifiedChangePass = "Dirección verificada, por favor introduzca una contraseña"+spanishMessage EmailVerified = "Dirección verificada" spanishMessage InvalidKeyTitle = "Clave de verificación invalida" spanishMessage InvalidKey = "Lo sentimos, pero esa clave de verificación es inválida." spanishMessage InvalidEmailPass = "La combinación cuenta de correo/contraseña es inválida"@@ -235,6 +243,8 @@ email `mappend` "." swedishMessage AddressVerified = "Adress verifierad, vänligen välj nytt lösenord"+swedishMessage EmailVerifiedChangePass = "Adress verifierad, vänligen välj nytt lösenord"+swedishMessage EmailVerified = "Adress verifierad" swedishMessage InvalidKeyTitle = "Ogiltig verifikationsnyckel" swedishMessage InvalidKey = "Tyvärr, du angav en ogiltig verifimationsnyckel." swedishMessage InvalidEmailPass = "Ogiltig epost/lösenord kombination"@@ -271,19 +281,21 @@ germanMessage LoginOpenID = "Login via OpenID" germanMessage LoginGoogle = "Login via Google" germanMessage LoginYahoo = "Login via Yahoo"-germanMessage Email = "Email"-germanMessage UserName = "Benutzername" -- FIXME by Google Translate "user name"+germanMessage Email = "E-Mail"+germanMessage UserName = "Benutzername" germanMessage Password = "Passwort" germanMessage CurrentPassword = "Aktuelles Passwort" germanMessage Register = "Registrieren" germanMessage RegisterLong = "Neuen Account registrieren"-germanMessage EnterEmail = "Bitte die e-Mail Adresse angeben, eine Bestätigungsmail wird verschickt."+germanMessage EnterEmail = "Bitte die E-Mail Adresse angeben, eine Bestätigungsmail wird verschickt." germanMessage ConfirmationEmailSentTitle = "Bestätigung verschickt." germanMessage (ConfirmationEmailSent email) = "Eine Bestätigung wurde an " `mappend` email `mappend` " versandt." germanMessage AddressVerified = "Adresse bestätigt, bitte neues Passwort angeben"+germanMessage EmailVerifiedChangePass = "Adresse bestätigt, bitte neues Passwort angeben"+germanMessage EmailVerified = "Adresse bestätigt" germanMessage InvalidKeyTitle = "Ungültiger Bestätigungsschlüssel" germanMessage InvalidKey = "Das war leider ein ungültiger Bestätigungsschlüssel" germanMessage InvalidEmailPass = "Ungültiger Nutzername oder Passwort"@@ -295,24 +307,23 @@ germanMessage PassMismatch = "Die Passwörter stimmen nicht überein" germanMessage PassUpdated = "Passwort überschrieben" germanMessage Facebook = "Login über Facebook"-germanMessage LoginViaEmail = "Login via e-Mail"+germanMessage LoginViaEmail = "Login via E-Mail" germanMessage InvalidLogin = "Ungültiger Login" germanMessage NowLoggedIn = "Login erfolgreich"-germanMessage LoginTitle = "Log In"+germanMessage LoginTitle = "Anmelden" germanMessage PleaseProvideUsername = "Bitte Nutzername angeben" germanMessage PleaseProvidePassword = "Bitte Passwort angeben"-germanMessage NoIdentifierProvided = "Keine Email-Adresse oder kein Nutzername angegeben"-germanMessage InvalidEmailAddress = "Unzulässiger Email-Anbieter"+germanMessage NoIdentifierProvided = "Keine E-Mail-Adresse oder kein Nutzername angegeben"+germanMessage InvalidEmailAddress = "Unzulässiger E-Mail-Anbieter" germanMessage PasswordResetTitle = "Passwort zurücksetzen"-germanMessage ProvideIdentifier = "Email-Adresse oder Nutzername"-germanMessage SendPasswordResetEmail = "Email zusenden um Passwort zurückzusetzen"-germanMessage PasswordResetPrompt = "Nach Einhabe der Email-Adresse oder des Nutzernamen wird eine Email zugesendet mit welcher das Passwort zurückgesetzt werden kann."+germanMessage ProvideIdentifier = "E-Mail-Adresse oder Nutzername"+germanMessage SendPasswordResetEmail = "E-Mail zusenden um Passwort zurückzusetzen"+germanMessage PasswordResetPrompt = "Nach Einhabe der E-Mail-Adresse oder des Nutzernamen wird eine E-Mail zugesendet mit welcher das Passwort zurückgesetzt werden kann." germanMessage InvalidUsernamePass = "Ungültige Kombination aus Nutzername und Passwort"--- TODO-germanMessage i@(IdentifierNotFound _) = englishMessage i-germanMessage Logout = "Ausloggen" -- FIXME by Google Translate-germanMessage LogoutTitle = "Ausloggen" -- FIXME by Google Translate-germanMessage AuthError = "Autorisierungsfehler" -- FIXME by Google Translate+germanMessage i@(IdentifierNotFound _) = englishMessage i -- TODO+germanMessage Logout = "Abmelden"+germanMessage LogoutTitle = "Abmelden"+germanMessage AuthError = "Fehler beim Anmelden" frenchMessage :: AuthMessage -> Text frenchMessage NoOpenID = "Aucun fournisseur OpenID n'a été trouvé"@@ -332,6 +343,8 @@ email `mappend` "." frenchMessage AddressVerified = "Votre adresse électronique a été validée, merci de choisir un nouveau mot de passe."+frenchMessage EmailVerifiedChangePass = "Votre adresse électronique a été validée, merci de choisir un nouveau mot de passe."+frenchMessage EmailVerified = "Votre adresse électronique a été validée" frenchMessage InvalidKeyTitle = "Clef de validation incorrecte" frenchMessage InvalidKey = "Désolé, mais cette clef de validation est incorrecte" frenchMessage InvalidEmailPass = "La combinaison de ce mot de passe et de cette adresse électronique n'existe pas."@@ -379,6 +392,8 @@ email `mappend` "." norwegianBokmålMessage AddressVerified = "Adresse verifisert, vennligst sett et nytt passord."+norwegianBokmålMessage EmailVerifiedChangePass = "Adresse verifisert, vennligst sett et nytt passord."+norwegianBokmålMessage EmailVerified = "Adresse verifisert" norwegianBokmålMessage InvalidKeyTitle = "Ugyldig verifiseringsnøkkel" norwegianBokmålMessage InvalidKey = "Beklager, men det var en ugyldig verifiseringsnøkkel." norwegianBokmålMessage InvalidEmailPass = "Ugyldig e-post/passord-kombinasjon"@@ -427,6 +442,8 @@ email `mappend` " に送信しました" japaneseMessage AddressVerified = "アドレスは認証されました。新しいパスワードを設定してください"+japaneseMessage EmailVerifiedChangePass = "アドレスは認証されました。新しいパスワードを設定してください"+japaneseMessage EmailVerified = "アドレスは認証されました" japaneseMessage InvalidKeyTitle = "認証キーが無効です" japaneseMessage InvalidKey = "申し訳ありません。無効な認証キーです" japaneseMessage InvalidEmailPass = "メールアドレスまたはパスワードが無効です"@@ -476,6 +493,8 @@ "." finnishMessage AddressVerified = "Sähköpostiosoite vahvistettu. Anna uusi salasana"+finnishMessage EmailVerifiedChangePass = "Sähköpostiosoite vahvistettu. Anna uusi salasana"+finnishMessage EmailVerified = "Sähköpostiosoite vahvistettu" finnishMessage InvalidKeyTitle = "Virheellinen varmistusavain" finnishMessage InvalidKey = "Valitettavasti varmistusavain on virheellinen." finnishMessage InvalidEmailPass = "Virheellinen sähköposti tai salasana."@@ -524,6 +543,8 @@ email `mappend` "." chineseMessage AddressVerified = "地址验证成功，请设置新密码"+chineseMessage EmailVerifiedChangePass = "地址验证成功，请设置新密码"+chineseMessage EmailVerified = "地址验证成功" chineseMessage InvalidKeyTitle = "无效的验证码" chineseMessage InvalidKey = "对不起，验证码无效。" chineseMessage InvalidEmailPass = "无效的邮箱/密码组合"@@ -569,6 +590,8 @@ czechMessage (ConfirmationEmailSent email) = "Potvrzovací e-mail byl odeslán na " `mappend` email `mappend` "." czechMessage AddressVerified = "Adresa byla ověřena, prosím nastavte si nové heslo"+czechMessage EmailVerifiedChangePass = "Adresa byla ověřena, prosím nastavte si nové heslo"+czechMessage EmailVerified = "Adresa byla ověřena" czechMessage InvalidKeyTitle = "Neplatný ověřovací klíč" czechMessage InvalidKey = "Bohužel, ověřovací klíč je neplatný." czechMessage InvalidEmailPass = "Neplatná kombinace e-mail/heslo"@@ -609,7 +632,7 @@ russianMessage Email = "Эл.почта" russianMessage UserName = "Имя пользователя" russianMessage Password = "Пароль"-russianMessage CurrentPassword = "Current password"+russianMessage CurrentPassword = "Старый пароль" russianMessage Register = "Регистрация" russianMessage RegisterLong = "Создать учётную запись" russianMessage EnterEmail = "Введите свой адрес эл.почты ниже, вам будет отправлено письмо для подтверждения."@@ -619,6 +642,8 @@ email `mappend` "." russianMessage AddressVerified = "Адрес подтверждён. Пожалуйста, установите новый пароль."+russianMessage EmailVerifiedChangePass = "Адрес подтверждён. Пожалуйста, установите новый пароль."+russianMessage EmailVerified = "Адрес подтверждён" russianMessage InvalidKeyTitle = "Неверный ключ подтверждения" russianMessage InvalidKey = "Извините, но ключ подтверждения оказался недействительным." russianMessage InvalidEmailPass = "Неверное сочетание эл.почты и пароля"@@ -666,6 +691,8 @@ email `mappend` "." dutchMessage AddressVerified = "Adres geverifieerd, stel alstublieft een nieuwe wachtwoord in"+dutchMessage EmailVerifiedChangePass = "Adres geverifieerd, stel alstublieft een nieuwe wachtwoord in"+dutchMessage EmailVerified = "Adres geverifieerd" dutchMessage InvalidKeyTitle = "Ongeldig verificatietoken" dutchMessage InvalidKey = "Dat was helaas een ongeldig verificatietoken." dutchMessage InvalidEmailPass = "Ongeldige e-mailadres/wachtwoord combinatie"@@ -713,6 +740,8 @@ croatianMessage ConfirmationEmailSentTitle = "E-poruka za potvrdu" croatianMessage (ConfirmationEmailSent email) = "E-poruka za potvrdu poslana je na adresu " <> email <> "." croatianMessage AddressVerified = "Adresa ovjerena, postavite novu lozinku"+croatianMessage EmailVerifiedChangePass = "Adresa ovjerena, postavite novu lozinku"+croatianMessage EmailVerified = "Adresa ovjerena" croatianMessage InvalidKeyTitle = "Ključ za ovjeru nije valjan" croatianMessage InvalidKey = "Nažalost, taj ključ za ovjeru nije valjan." croatianMessage InvalidEmailPass = "Kombinacija e-pošte i lozinke nije valjana"@@ -757,6 +786,8 @@ email `mappend` "." danishMessage AddressVerified = "Adresse bekræftet, sæt venligst et nyt kodeord"+danishMessage EmailVerifiedChangePass = "Adresse bekræftet, sæt venligst et nyt kodeord"+danishMessage EmailVerified = "Adresse bekræftet" danishMessage InvalidKeyTitle = "Ugyldig verifikationsnøgle" danishMessage InvalidKey = "Beklager, det var en ugyldigt verifikationsnøgle." danishMessage InvalidEmailPass = "Ugyldigt e-mail/kodeord"@@ -804,6 +835,8 @@ email `mappend` "에 보냈습니다." koreanMessage AddressVerified = "주소가 인증되었습니다. 새 비밀번호를 설정하세요."+koreanMessage EmailVerifiedChangePass = "주소가 인증되었습니다. 새 비밀번호를 설정하세요."+koreanMessage EmailVerified = "주소가 인증되었습니다" koreanMessage InvalidKeyTitle = "인증키가 잘못되었습니다" koreanMessage InvalidKey = "죄송합니다. 잘못된 인증키입니다." koreanMessage InvalidEmailPass = "이메일 주소나 비밀번호가 잘못되었습니다"@@ -832,3 +865,54 @@ koreanMessage Logout = "로그아웃" koreanMessage LogoutTitle = "로그아웃" koreanMessage AuthError = "인증오류"++-- | Romanian translation+--+-- @since 1.6.11.3+romanianMessage :: AuthMessage -> Text+romanianMessage NoOpenID = "Identificatorul OpenID nu a fost găsit"+romanianMessage LoginOpenID = "Conectați-vă cu OpenID"+romanianMessage LoginGoogle = "Conectați-vă cu Google"+romanianMessage LoginYahoo = "Conectați-vă cu Yahoo"+romanianMessage Email = "E-mail"+romanianMessage UserName = "Nume de utilizator"+romanianMessage Password = "Parolă"+romanianMessage CurrentPassword = "Parola curentă"+romanianMessage Register = "Înregistrează-te"+romanianMessage RegisterLong = "Înregistrați un cont nou"+romanianMessage EnterEmail = "Introduceți adresa dvs. de e-mail pentru a primi un e-mail de confirmare."+romanianMessage ConfirmationEmailSentTitle = "Un mesaj de confirmare a fost trimis la adresa dvs. de e-mail"+romanianMessage (ConfirmationEmailSent email) =+ "Un mesaj de confirmare a fost trimis la " `mappend` email `mappend` "."+romanianMessage AddressVerified = "Adresa de e-mail a fost verificată, vă rugăm să setați o parolă nouă"+romanianMessage EmailVerifiedChangePass = "Adresa de e-mail a fost verificată, vă rugăm să setați o parolă nouă"+romanianMessage EmailVerified = "Adresa de e-mail a fost verificată"+romanianMessage InvalidKeyTitle = "Cheie de verificare nevalidă"+romanianMessage InvalidKey = "Cheie de verificare nevalidă."+romanianMessage InvalidEmailPass = "Nume de utilizator și/sau parolă incorect(ă)"+romanianMessage BadSetPass = "Trebuie să fiți autentificat pentru a seta parola"+romanianMessage SetPassTitle = "Setarea parolei"+romanianMessage SetPass = "Setează parolă nouă"+romanianMessage NewPass = "Parolă nouă"+romanianMessage ConfirmPass = "Confirmă"+romanianMessage PassMismatch = "Parolele nu se potrivesc, vă rugăm să încercați din nou"+romanianMessage PassUpdated = "Parola a fost actualizată"+romanianMessage Facebook = "Conectați-vă cu Facebook"+romanianMessage LoginViaEmail = "Conectați-vă cu contul de e-mail"+romanianMessage InvalidLogin = "Nume de utilizator incorect"+romanianMessage NowLoggedIn = "Felicitări. Acum sunteți autentificat."+romanianMessage LoginTitle = "Autentificare"+romanianMessage PleaseProvideUsername = "Introduceți, vă rog, numele dvs. de utilizator"+romanianMessage PleaseProvidePassword = "Introduceți, vă rog, parola dvs."+romanianMessage NoIdentifierProvided = "Adresa de e-mail sau numele de utilizator nu sunt furnizate."+romanianMessage InvalidEmailAddress = "Adresă de e-mail nevalidă"+romanianMessage PasswordResetTitle = "Resetarea parolei"+romanianMessage ProvideIdentifier = "Adresă de e-mail sau nume de utilizator"+romanianMessage SendPasswordResetEmail = "Trimite un e-mail pentru resetarea parolei"+romanianMessage PasswordResetPrompt =+ "Introduceți adresa dvs. de e-mail sau numele de utilizator pentru a primi un e-mail de resetare a parolei."+romanianMessage InvalidUsernamePass = "Nume de utilizator și/sau parolă incorect(ă)"+romanianMessage (IdentifierNotFound ident) = "Numele de utilizator nu a fost găsit: " `mappend` ident+romanianMessage Logout = "Deconectați-vă"+romanianMessage LogoutTitle = "Deconectare"+romanianMessage AuthError = "Eroare de autentificare"
Yesod/Auth/OpenId.hs view
@@ -1,8 +1,9 @@ {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE CPP #-}+{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RankNTypes #-}+ module Yesod.Auth.OpenId ( authOpenId , forwardUrl@@ -19,7 +20,7 @@ import Yesod.Core import Data.Text (Text, isPrefixOf) import qualified Yesod.Auth.Message as Msg-import Control.Exception.Lifted (SomeException, try)+import UnliftIO.Exception (tryAny) import Data.Maybe (fromMaybe) import qualified Data.Text as T @@ -36,7 +37,10 @@ AuthPlugin "openid" dispatch login where complete = PluginR "openid" ["complete"]++ name :: Text name = "openid_identifier"+ login tm = do ident <- newIdent -- FIXME this is a hack to get GHC 7.6's type checker to allow the@@ -57,19 +61,19 @@ <input id="#{ident}" type="text" name="#{name}" value="http://"> <input type="submit" value="_{Msg.LoginOpenID}"> |]++ dispatch :: Text -> [Text] -> AuthHandler master TypedContent dispatch "GET" ["forward"] = do- roid <- lift $ runInputGet $ iopt textField name+ roid <- runInputGet $ iopt textField name case roid of Just oid -> do+ tm <- getRouteToParent render <- getUrlRender- let complete' = render complete- master <- lift getYesod- eres <- lift $ try $ OpenId.getForwardUrl oid complete' Nothing extensionFields (authHttpManager master)+ let complete' = render $ tm complete+ manager <- authHttpManager+ eres <- tryAny $ OpenId.getForwardUrl oid complete' Nothing extensionFields manager case eres of- Left err -> do- tm <- getRouteToParent- lift $ loginErrorMessage (tm LoginR) $ T.pack $- show (err :: SomeException)+ Left err -> loginErrorMessage (tm LoginR) $ T.pack $ show err Right x -> redirect x Nothing -> loginErrorMessageI LoginR Msg.NoOpenID dispatch "GET" ["complete", ""] = dispatch "GET" ["complete"] -- compatibility issues@@ -84,14 +88,13 @@ completeHelper :: IdentifierType -> [(Text, Text)] -> AuthHandler master TypedContent completeHelper idType gets' = do- master <- lift getYesod- eres <- try $ OpenId.authenticateClaimed gets' (authHttpManager master)+ manager <- authHttpManager+ eres <- tryAny $ OpenId.authenticateClaimed gets' manager either onFailure onSuccess eres where onFailure err = do tm <- getRouteToParent- lift $ loginErrorMessage (tm LoginR) $ T.pack $- show (err :: SomeException)+ loginErrorMessage (tm LoginR) $ T.pack $ show err onSuccess oir = do let claimed = case OpenId.oirClaimed oir of@@ -105,7 +108,7 @@ case idType of OPLocal -> OpenId.oirOpLocal oir Claimed -> fromMaybe (OpenId.oirOpLocal oir) $ OpenId.oirClaimed oir- lift $ setCredsRedirect $ Creds "openid" i gets''+ setCredsRedirect $ Creds "openid" i gets'' -- | The main identifier provided by the OpenID authentication plugin is the -- \"OP-local identifier\". There is also sometimes a \"claimed\" identifier
Yesod/Auth/Routes.hs view
@@ -1,11 +1,13 @@-{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-}+ module Yesod.Auth.Routes where import Yesod.Core
Yesod/Auth/Rpxnow.hs view
@@ -1,7 +1,9 @@-{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE FlexibleContexts #-}+ module Yesod.Auth.Rpxnow ( authRpxnow ) where@@ -17,10 +19,10 @@ import Control.Arrow ((***)) import Network.HTTP.Types (renderQuery) -authRpxnow :: YesodAuth m+authRpxnow :: YesodAuth master => String -- ^ app name -> String -- ^ key- -> AuthPlugin m+ -> AuthPlugin master authRpxnow app apiKey = AuthPlugin "rpxnow" dispatch login where@@ -32,14 +34,16 @@ $newline never <iframe src="http://#{app}.rpxnow.com/openid/embed#{queryString}" scrolling="no" frameBorder="no" allowtransparency="true" style="width:400px;height:240px"> |]++ dispatch :: a -> [b] -> AuthHandler master TypedContent dispatch _ [] = do token1 <- lookupGetParams "token" token2 <- lookupPostParams "token" token <- case token1 ++ token2 of [] -> invalidArgs ["token: Value not supplied"] x:_ -> return $ unpack x- master <- lift getYesod- Rpxnow.Identifier ident extra <- lift $ Rpxnow.authenticate apiKey token (authHttpManager master)+ manager <- authHttpManager+ Rpxnow.Identifier ident extra <- Rpxnow.authenticate apiKey token manager let creds = Creds "rpxnow" ident $ maybe id (\x -> (:) ("verifiedEmail", x))@@ -47,7 +51,7 @@ $ maybe id (\x -> (:) ("displayName", x)) (fmap pack $ getDisplayName $ map (unpack *** unpack) extra) []- lift $ setCredsRedirect creds+ setCredsRedirect creds dispatch _ _ = notFound -- | Get some form of a display name.
Yesod/Auth/Util/PasswordStore.hs view
@@ -1,5 +1,6 @@-{-# LANGUAGE OverloadedStrings, BangPatterns #-}-{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+ -- | -- This is a fork of pwstore-fast, originally copyright (c) Peter Scott, 2011, -- and released under a BSD-style licence.@@ -169,7 +170,7 @@ let hLen = 32 dkLen = hLen in go hLen dkLen where- go hLen dkLen | dkLen > (2^(32 :: Int) - 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@@ -233,15 +234,16 @@ -- | Try to parse a password hash. readPwHash :: ByteString -> Maybe (Int, Salt, ByteString)-readPwHash pw | length broken /= 4- || algorithm /= "sha256"- || B.length hash /= 44 = Nothing- | otherwise = case B.readInt strBS of- Just (strength, _) -> Just (strength, SaltBS salt, hash)- Nothing -> Nothing- where broken = B.split '|' pw- [algorithm, strBS, salt, hash] = broken+readPwHash pw+ | ["sha256", strBS, salt, hash] <- broken+ , B.length hash == 44 =+ (\(strength, _) -> (strength, SaltBS salt, hash))+ <$> B.readInt strBS+ | otherwise = Nothing+ where+ broken = B.split '|' pw + -- | Encode a password hash, from a @(strength, salt, hash)@ tuple, where -- strength is an 'Int', and both @salt@ and @hash@ are base64-encoded -- 'ByteString's.@@ -280,7 +282,7 @@ -> IO ByteString makePasswordWith algorithm password strength = do salt <- genSaltIO- return $ makePasswordSaltWith algorithm (2^) password salt strength+ return $ makePasswordSaltWith algorithm (2 ^) password salt strength -- | A generic version of 'makePasswordSalt', meant to give the user -- the maximum control over the generation parameters.@@ -314,7 +316,7 @@ -- @since 1.4.18 -- makePasswordSalt :: ByteString -> Salt -> Int -> ByteString-makePasswordSalt = makePasswordSaltWith pbkdf1 (2^)+makePasswordSalt = makePasswordSaltWith pbkdf1 (2 ^) -- | 'verifyPasswordWith' @algorithm userInput pwHash@ verifies -- the password @userInput@ given by the user against the stored password@@ -351,7 +353,7 @@ -- @since 1.4.18 -- verifyPassword :: ByteString -> ByteString -> Bool-verifyPassword = verifyPasswordWith pbkdf1 (2^)+verifyPassword = verifyPasswordWith pbkdf1 (2 ^) -- | Try to strengthen a password hash, by hashing it some more -- times. @'strengthenPassword' pwHash new_strength@ will return a new password@@ -376,7 +378,7 @@ else pwHash where newHash = encode $ hashRounds hash extraRounds- extraRounds = (2^newstr) - (2^oldstr)+ extraRounds = (2 ^ newstr) - (2 ^ oldstr) hash = decodeLenient hashB64 -- | Return the strength of a password hash.@@ -453,12 +455,3 @@ where (a, g') = randomR ('\NUL', '\255') g salt = makeSalt $ B.pack $ map fst (rands gen 16) newgen = snd $ last (rands gen 16)--#if !MIN_VERSION_base(4, 6, 0)--- | Strict version of 'modifySTRef'-modifySTRef' :: STRef s a -> (a -> a) -> ST s ()-modifySTRef' ref f = do- x <- readSTRef ref- let x' = f x- x' `seq` writeSTRef ref x'-#endif
yesod-auth.cabal view
@@ -1,5 +1,6 @@+cabal-version: >=1.10 name: yesod-auth-version: 1.4.21+version: 1.6.12.1 license: MIT license-file: LICENSE author: Michael Snoyman, Patrick Brisbin@@ -7,7 +8,6 @@ synopsis: Authentication for Yesod. category: Web, Yesod stability: Stable-cabal-version: >= 1.6.0 build-type: Simple homepage: http://www.yesodweb.com/ description: API docs and the README are available at <http://www.stackage.org/package/yesod-auth>@@ -20,52 +20,49 @@ default: True library- build-depends: base >= 4 && < 5- , authenticate >= 1.3- , bytestring >= 0.9.1.4- , yesod-core >= 1.4.31 && < 1.5- , wai >= 1.4- , template-haskell- , base16-bytestring- , cryptonite- , memory- , random >= 1.0.0.2- , text >= 0.7- , mime-mail >= 0.3- , yesod-persistent >= 1.4- , shakespeare- , containers- , unordered-containers- , yesod-form >= 1.4 && < 1.5- , transformers >= 0.2.2- , persistent >= 2.1 && < 2.8- , persistent-template >= 2.1 && < 2.8- , http-client- , http-conduit >= 2.1+ default-language: Haskell2010+ build-depends: base >= 4.11 && < 5 , aeson >= 0.7- , lifted-base >= 0.1- , blaze-html >= 0.5- , blaze-markup >= 0.5.1- , http-types- , file-embed- , email-validate >= 1.0- , data-default- , resourcet- , safe- , time+ , attoparsec-aeson >= 2.1+ , authenticate >= 1.3.4+ , base16-bytestring , base64-bytestring- , byteable , binary- , http-client , blaze-builder- , conduit+ , blaze-html >= 0.5+ , blaze-markup >= 0.5.1+ , bytestring >= 0.9.1.4+ , conduit >= 1.3 , conduit-extra+ , containers+ , crypton+ , data-default+ , email-validate >= 1.0+ , file-embed+ , http-client >= 0.5+ , http-client-tls+ , http-conduit >= 2.1+ , http-types+ , memory , nonce >= 1.0.2 && < 1.1+ , persistent >= 2.8+ , random >= 1.0.0.2+ , safe+ , shakespeare+ , template-haskell+ , text >= 0.7+ , time+ , transformers >= 0.2.2+ , unliftio+ , unliftio-core+ , unordered-containers+ , wai >= 1.4+ , yesod-core >= 1.6 && < 1.8+ , yesod-form >= 1.6 && < 1.8+ , 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@@ -74,7 +71,6 @@ Yesod.Auth.OpenId Yesod.Auth.Rpxnow Yesod.Auth.Message- Yesod.Auth.GoogleEmail Yesod.Auth.GoogleEmail2 Yesod.Auth.Hardcoded Yesod.Auth.Util.PasswordStore