yesod-auth 1.4.21 → 1.6.0
raw patch · 11 files changed
+278/−349 lines, 11 filesdep +http-client-tlsdep +unliftiodep +unliftio-coredep −lifted-basedep ~authenticatedep ~basedep ~conduit
Dependencies added: http-client-tls, unliftio, unliftio-core
Dependencies removed: lifted-base
Dependency ranges changed: authenticate, base, conduit, conduit-extra, http-client, http-conduit, persistent, resourcet, yesod-core, yesod-form, yesod-persistent
Files
- ChangeLog.md +4/−0
- Yesod/Auth.hs +106/−101
- Yesod/Auth/BrowserId.hs +8/−7
- Yesod/Auth/Dummy.hs +4/−2
- Yesod/Auth/Email.hs +84/−79
- Yesod/Auth/GoogleEmail.hs +0/−89
- Yesod/Auth/GoogleEmail2.hs +23/−31
- Yesod/Auth/Hardcoded.hs +12/−11
- Yesod/Auth/OpenId.hs +17/−14
- Yesod/Auth/Rpxnow.hs +8/−5
- yesod-auth.cabal +12/−10
ChangeLog.md view
@@ -1,3 +1,7 @@+## 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)
Yesod/Auth.hs view
@@ -39,6 +39,7 @@ -- * Exception , AuthException (..) -- * Helper+ , MonadAuthHandler , AuthHandler -- * Internal , credsKey@@ -47,9 +48,9 @@ , asHtml ) where -import Control.Applicative ((<$>)) import Control.Monad (when) import Control.Monad.Trans.Maybe+import UnliftIO (withRunInIO, MonadUnliftIO) import Yesod.Auth.Routes import Data.Aeson hiding (json)@@ -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,20 @@ 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) 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 +95,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 +112,8 @@ type AuthId master -- | specify the layout. Uses defaultLayout by default- authLayout :: WidgetT master IO () -> HandlerT master IO Html- authLayout = defaultLayout+ authLayout :: WidgetFor master () -> AuthHandler master Html+ authLayout = liftHandler . defaultLayout -- | Default destination on successful login, if no other -- destination exists.@@ -126,8 +127,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 :: Creds master -> AuthHandler master (AuthenticationResult master) authenticate creds = do muid <- getAuthId creds @@ -137,7 +138,7 @@ -- -- Default implementation is in terms of @'authenticate'@ --- getAuthId :: Creds master -> HandlerT master IO (Maybe (AuthId master))+ getAuthId :: Creds master -> AuthHandler master (Maybe (AuthId master)) getAuthId creds = do auth <- authenticate creds @@ -167,7 +168,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 +185,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 +194,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 :: AuthHandler master Manager+ authHttpManager = liftIO getGlobalManager -- | Called on a successful login. By default, calls -- @addMessageI "success" NowLoggedIn@.- onLogin :: HandlerT master IO ()+ onLogin :: AuthHandler master () onLogin = addMessageI "success" Msg.NowLoggedIn -- | Called on logout. By default, does nothing- onLogout :: HandlerT master IO ()+ onLogout :: AuthHandler master () onLogout = return () -- | Retrieves user credentials, if user is authenticated.@@ -211,17 +214,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 :: AuthHandler master (Maybe (AuthId master)) default maybeAuthId :: (YesodAuthPersist master, Typeable (AuthEntity master))- => HandlerT master IO (Maybe (AuthId master))+ => AuthHandler master (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 :: Route master -> Text -> AuthHandler master Html onErrorHtml dest msg = do addMessage "error" $ toHtml msg fmap asHtml $ redirect dest@@ -231,10 +234,14 @@ -- -- 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+ :: MonadAuthHandler master 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 #-} @@ -242,7 +249,7 @@ -- | Internal session key used to hold the authentication information. ----- Since 1.2.3+-- @since 1.2.3 credsKey :: Text credsKey = "_ID" @@ -252,10 +259,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))+ => AuthHandler master (Maybe (AuthId master)) defaultMaybeAuthId = runMaybeT $ do s <- MaybeT $ lookupSession credsKey aid <- MaybeT $ return $ fromPathPiece s@@ -264,7 +271,8 @@ cachedAuth :: (YesodAuthPersist master, Typeable (AuthEntity master))- => AuthId master -> HandlerT master IO (Maybe (AuthEntity master))+ => AuthId master+ -> AuthHandler master (Maybe (AuthEntity master)) cachedAuth = fmap unCachedMaybeAuth . cached@@ -277,52 +285,57 @@ -- 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+ :: Route master+ -> AuthMessage+ -> AuthHandler master 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+ :: Route master -> Text- -> HandlerT master m TypedContent+ -> AuthHandler master TypedContent loginErrorMessage dest msg = messageJson401 msg (onErrorHtml dest msg) -messageJson401 :: MonadResourceBase m => Text -> HandlerT master m Html -> HandlerT master m TypedContent+messageJson401+ :: MonadAuthHandler master m+ => Text+ -> m Html+ -> m TypedContent messageJson401 = messageJsonStatus unauthorized401 -messageJson500 :: MonadResourceBase m => Text -> HandlerT master m Html -> HandlerT master m TypedContent+messageJson500 :: MonadAuthHandler master m => Text -> m Html -> m TypedContent messageJson500 = messageJsonStatus internalServerError500 -messageJsonStatus :: MonadResourceBase m- => Status- -> Text- -> HandlerT master m Html- -> HandlerT master m TypedContent+messageJsonStatus+ :: MonadAuthHandler master m+ => Status+ -> Text+ -> m Html+ -> m TypedContent messageJsonStatus status msg html = selectRep $ do provideRep html provideRep $ do@@ -334,9 +347,9 @@ provideJsonMessage msg = provideRep $ return $ object ["message" .= msg] -setCredsRedirect :: YesodAuth master- => Creds master -- ^ new credentials- -> HandlerT master IO TypedContent+setCredsRedirect+ :: Creds master -- ^ new credentials+ -> AuthHandler master TypedContent setCredsRedirect creds = do y <- getYesod auth <- authenticate creds@@ -375,10 +388,9 @@ 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+setCreds :: Bool -- ^ if HTTP redirects should be done -> Creds master -- ^ new credentials- -> HandlerT master IO ()+ -> AuthHandler master () setCreds doRedirects creds = if doRedirects then void $ setCredsRedirect creds@@ -388,20 +400,20 @@ _ -> 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 :: Bool -- ^ if HTTP redirect to 'logoutDest' should be done+ -> AuthHandler master () clearCreds doRedirects = do y <- getYesod onLogout@@ -410,7 +422,7 @@ redirectUltDest $ logoutDest y getCheckR :: AuthHandler master TypedContent-getCheckR = lift $ do+getCheckR = do creds <- maybeAuthId authLayoutJson (do setTitle "Authentication Status"@@ -431,7 +443,7 @@ ] setUltDestReferer' :: AuthHandler master ()-setUltDestReferer' = lift $ do+setUltDestReferer' = do master <- getYesod when (redirectToReferer master) setUltDestReferer @@ -439,14 +451,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 +471,22 @@ -- 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+ ) => AuthHandler master (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))+ => AuthHandler master (Maybe (AuthId master, AuthEntity master)) maybeAuthPair = runMaybeT $ do aid <- MaybeT maybeAuthId ae <- MaybeT $ cachedAuth aid@@ -492,7 +505,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 +513,20 @@ -- > type AuthId MySite = UserId -- > AuthEntity MySite ~ User --- -- Since 1.2.0+ -- @since 1.2.0 type AuthEntity master :: * type AuthEntity master = KeyEntity (AuthId master) - getAuthEntity :: AuthId master -> HandlerT master IO (Maybe (AuthEntity master))+ getAuthEntity :: AuthId master -> AuthHandler master (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)- )- => AuthId master -> HandlerT master IO (Maybe (AuthEntity master))-#endif- getAuthEntity = runDB . get+ => AuthId master -> AuthHandler master (Maybe (AuthEntity master))+ getAuthEntity = liftHandler . runDB . get type family KeyEntity key@@ -533,36 +535,39 @@ -- | 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 :: AuthHandler master (AuthId master) 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)+ ) => AuthHandler master (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)+ )+ => AuthHandler master (AuthId master, AuthEntity master) requireAuthPair = maybeAuthPair >>= maybe handleAuthLack return -handleAuthLack :: YesodAuth master => HandlerT master IO a+handleAuthLack :: AuthHandler master a handleAuthLack = do aj <- acceptsJson if aj then notAuthenticated else redirectLogin -redirectLogin :: YesodAuth master => HandlerT master IO a+redirectLogin :: AuthHandler master a redirectLogin = do y <- getYesod when (redirectToCurrent y) setUltDestCurrent@@ -577,7 +582,7 @@ deriving (Show, Typeable) 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
@@ -70,20 +70,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 +117,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 +166,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,5 +1,7 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}+{-# 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.@@ -16,8 +18,8 @@ AuthPlugin "dummy" dispatch login where dispatch "POST" [] = do- ident <- lift $ runInputPost $ ireq textField "ident"- lift $ setCredsRedirect $ Creds "dummy" ident []+ ident <- runInputPost $ ireq textField "ident"+ setCredsRedirect $ Creds "dummy" ident [] dispatch _ _ = notFound url = PluginR "dummy" [] login authToMaster = do
Yesod/Auth/Email.hs view
@@ -186,29 +186,29 @@ -- has not yet been verified. -- -- @since 1.1.0- addUnverified :: Email -> VerKey -> HandlerT site IO (AuthEmailId site)+ addUnverified :: Email -> VerKey -> AuthHandler site (AuthEmailId site) -- | 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 () -- | 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 :: Text -> AuthHandler site SaltedPass hashAndSaltPassword = liftIO . saltPass -- | Verify a password matches the stored password for the given account.@@ -216,7 +216,7 @@ -- 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 +228,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. --@@ -268,7 +268,7 @@ -- 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 +280,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 +288,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@@ -314,7 +314,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 +325,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 +335,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,7 +351,7 @@ -- 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 authEmail :: (YesodAuthEmail m) => AuthPlugin m@@ -371,15 +371,18 @@ 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}>@@ -437,11 +440,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}@@ -480,14 +483,14 @@ registerHelper :: YesodAuthEmail master => Bool -- ^ allow usernames? -> Route Auth- -> HandlerT Auth (HandlerT master IO) TypedContent+ -> AuthHandler master TypedContent registerHelper allowUsername dest = do- y <- lift getYesod+ y <- getYesod checkCsrfHeaderOrParam defaultCsrfHeaderName defaultCsrfParamName pidentifier <- lookupPostParam "email" midentifier <- case pidentifier of Nothing -> do- (jidentifier :: Result Value) <- lift parseCheckJsonBody+ (jidentifier :: Result Value) <- parseCheckJsonBody case jidentifier of Error _ -> return Nothing Success val -> return $ parseMaybe parseEmail val@@ -502,43 +505,44 @@ case eidentifier of Left route -> loginErrorMessageI dest route 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 key <- liftIO $ randomKey y- lift $ setVerifyKey lid key+ setVerifyKey lid key return $ Just (lid, key, email) Nothing | allowUsername -> return Nothing | otherwise -> do key <- liftIO $ randomKey y- lid <- lift $ addUnverified identifier key+ lid <- addUnverified identifier key return $ Just (lid, 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+ tp <- getRouteToParent+ let verUrl = render $ tp $ verifyR (toPathPiece lid) verKey+ sendVerifyEmail email verKey verUrl+ confirmationEmailSentResponse identifier -postRegisterR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent+postRegisterR :: YesodAuthEmail master => AuthHandler master TypedContent postRegisterR = registerHelper False registerR -getForgotPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html+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}@@ -569,35 +573,36 @@ fsAttrs = [("autofocus", "")] } -postForgotPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent+postForgotPasswordR :: YesodAuthEmail master => AuthHandler master TypedContent postForgotPasswordR = registerHelper True forgotPasswordR getVerifyR :: YesodAuthEmail site => AuthEmailId site -> Text- -> HandlerT Auth (HandlerT site IO) TypedContent+ -> AuthHandler site TypedContent getVerifyR lid key = do- realKey <- lift $ getVerifyKey lid- memail <- lift $ getEmail lid- mr <- lift getMessageRender+ 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+ setCreds False $ Creds "email-verify" email [("verifiedEmail", email)] -- FIXME uid?+ setLoginLinkKey uid let msgAv = Msg.AddressVerified selectRep $ do provideRep $ do- lift $ addMessageI "success" msgAv- fmap asHtml $ redirect setpassR+ addMessageI "success" msgAv+ tp <- getRouteToParent+ fmap asHtml $ redirect $ tp setpassR 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,16 +617,16 @@ 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 Success val -> return $ parseMaybe parseCreds val@@ -629,18 +634,18 @@ 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 +653,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 +663,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+ needOld <- maybe (return True) needOldPassword maid 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}@@ -749,10 +754,10 @@ 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 Success val -> parseMaybe parsePassword val@@ -761,26 +766,26 @@ 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 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@@ -789,7 +794,7 @@ getNewConfirm (Just (a,b,_)) = Just (a,b) getNewConfirm _ = Nothing confirmPassword aid tm jcreds = do- res <- lift $ runInputPostResult $ (,)+ res <- runInputPostResult $ (,) <$> ireq textField "new" <*> ireq textField "confirm" let creds = if (isJust jcreds)@@ -803,21 +808,21 @@ 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+ salted <- hashAndSaltPassword new+ y <- do setPassword aid salted deleteSession loginLinkKey addMessageI "success" msgOk getYesod - mr <- lift getMessageRender+ mr <- getMessageRender selectRep $ do provideRep $ - fmap asHtml $ lift $ redirect $ afterPasswordRoute y+ fmap asHtml $ redirect $ afterPasswordRoute y 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
@@ -2,6 +2,8 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# 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@@ -54,16 +56,16 @@ AuthRoute, Creds (Creds), Route (PluginR), YesodAuth, runHttpRequest, setCredsRedirect,- logoutDest)+ logoutDest, AuthHandler) import qualified Yesod.Auth.Message as Msg-import Yesod.Core (HandlerSite, HandlerT, MonadHandler,+import Yesod.Core (HandlerSite, MonadHandler, TypedContent, getRouteToParent, getUrlRender, invalidArgs,- lift, liftIO, lookupGetParam,+ liftIO, lookupGetParam, lookupSession, notFound, redirect, setSession, whamlet, (.:), addMessage, getYesod,- toHtml)+ toHtml, liftSubHandler) import Blaze.ByteString.Builder (fromByteString, toByteString)@@ -82,7 +84,7 @@ import Data.Aeson.Parser (json') import Data.Aeson.Types (FromJSON (parseJSON), parseEither, parseMaybe, withObject, withText)-import Data.Conduit (($$+-), ($$))+import Data.Conduit import Data.Conduit.Attoparsec (sinkParser) import qualified Data.HashMap.Strict as M import Data.Maybe (fromMaybe)@@ -187,10 +189,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 +209,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'@@ -257,38 +256,31 @@ [e] -> return e [] -> error "No account email" x -> error $ "Too many account emails: " ++ show x- lift $ setCredsRedirect $ Creds pid email $ allPersonInfo personValue+ 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 :: Manager -> Token -> AuthHandler site (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)
Yesod/Auth/Hardcoded.hs view
@@ -131,9 +131,10 @@ , loginR ) where -import Yesod.Auth (Auth, AuthPlugin (..), AuthRoute,+import Yesod.Auth (AuthPlugin (..), AuthRoute, Creds (..), Route (..), YesodAuth,- loginErrorMessageI, setCredsRedirect)+ loginErrorMessageI, setCredsRedirect,+ AuthHandler) import qualified Yesod.Auth.Message as Msg import Yesod.Core import Yesod.Form (ireq, runInputPost, textField)@@ -148,10 +149,10 @@ 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@@ -182,16 +183,16 @@ |] -postLoginR :: (YesodAuthHardcoded master)- => HandlerT Auth (HandlerT master IO) TypedContent+postLoginR :: YesodAuthHardcoded site+ => AuthHandler site TypedContent postLoginR =- do (username, password) <- lift (runInputPost+ do (username, password) <- runInputPost ((,) Control.Applicative.<$> ireq textField "username"- Control.Applicative.<*> ireq textField "password"))- isValid <- lift (validatePassword username password)+ Control.Applicative.<*> 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/OpenId.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE GADTs #-} 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/Rpxnow.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-} module Yesod.Auth.Rpxnow ( authRpxnow ) where@@ -17,10 +18,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 +33,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 +50,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.cabal view
@@ -1,5 +1,5 @@ name: yesod-auth-version: 1.4.21+version: 1.6.0 license: MIT license-file: LICENSE author: Michael Snoyman, Patrick Brisbin@@ -21,9 +21,9 @@ library build-depends: base >= 4 && < 5- , authenticate >= 1.3+ , authenticate >= 1.3.4 , bytestring >= 0.9.1.4- , yesod-core >= 1.4.31 && < 1.5+ , yesod-core >= 1.6 && < 1.7 , wai >= 1.4 , template-haskell , base16-bytestring@@ -32,18 +32,19 @@ , random >= 1.0.0.2 , text >= 0.7 , mime-mail >= 0.3- , yesod-persistent >= 1.4+ , yesod-persistent >= 1.6 , shakespeare , containers , unordered-containers- , yesod-form >= 1.4 && < 1.5+ , yesod-form >= 1.6 && < 1.7 , transformers >= 0.2.2- , persistent >= 2.1 && < 2.8+ , persistent >= 2.8 && < 2.9 , persistent-template >= 2.1 && < 2.8- , http-client+ , http-client >= 0.5+ , http-client-tls , http-conduit >= 2.1 , aeson >= 0.7- , lifted-base >= 0.1+ , unliftio , blaze-html >= 0.5 , blaze-markup >= 0.5.1 , http-types@@ -58,9 +59,11 @@ , binary , http-client , blaze-builder- , conduit+ , conduit >= 1.3 , conduit-extra , nonce >= 1.0.2 && < 1.1+ , unliftio-core+ , unliftio if flag(network-uri) build-depends: network-uri >= 2.6@@ -74,7 +77,6 @@ Yesod.Auth.OpenId Yesod.Auth.Rpxnow Yesod.Auth.Message- Yesod.Auth.GoogleEmail Yesod.Auth.GoogleEmail2 Yesod.Auth.Hardcoded Yesod.Auth.Util.PasswordStore