From 8e265f6ebc500d2eff2169ea0727c0dbb8b23404 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Mon, 18 Dec 2017 15:04:45 +0200 Subject: [PATCH] It all compiles --- yesod-auth-oauth/Yesod/Auth/OAuth.hs | 33 ++++-- yesod-auth-oauth/yesod-auth-oauth.cabal | 1 + yesod-auth/Yesod/Auth.hs | 140 ++++++++++++------------ yesod-auth/Yesod/Auth/BrowserId.hs | 12 +- yesod-auth/Yesod/Auth/Dummy.hs | 3 +- yesod-auth/Yesod/Auth/Email.hs | 133 +++++++++++----------- yesod-auth/Yesod/Auth/GoogleEmail.hs | 89 --------------- yesod-auth/Yesod/Auth/GoogleEmail2.hs | 43 +++----- yesod-auth/Yesod/Auth/Hardcoded.hs | 23 ++-- yesod-auth/Yesod/Auth/OpenId.hs | 26 +++-- yesod-auth/Yesod/Auth/Rpxnow.hs | 14 ++- yesod-auth/yesod-auth.cabal | 5 +- yesod-static/Yesod/Static.hs | 7 +- 13 files changed, 228 insertions(+), 301 deletions(-) delete mode 100644 yesod-auth/Yesod/Auth/GoogleEmail.hs diff --git a/yesod-auth-oauth/Yesod/Auth/OAuth.hs b/yesod-auth-oauth/Yesod/Auth/OAuth.hs index 9a5d3a0e..6e723c08 100644 --- a/yesod-auth-oauth/Yesod/Auth/OAuth.hs +++ b/yesod-auth-oauth/Yesod/Auth/OAuth.hs @@ -1,5 +1,8 @@ {-# LANGUAGE DeriveDataTypeable, OverloadedStrings, QuasiQuotes #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} module Yesod.Auth.OAuth ( authOAuth , oauthUrl @@ -14,6 +17,7 @@ import Control.Applicative as A ((<$>), (<*>)) import Control.Arrow ((***)) import Control.Exception.Lifted import Control.Monad.IO.Class +import Control.Monad.IO.Unlift (MonadUnliftIO) import Data.ByteString (ByteString) import Data.Maybe import Data.Text (Text) @@ -35,26 +39,37 @@ instance Exception YesodOAuthException oauthUrl :: Text -> AuthRoute oauthUrl name = PluginR name ["forward"] -authOAuth :: YesodAuth m +authOAuth :: forall master. YesodAuth master => OAuth -- ^ 'OAuth' data-type for signing. - -> (Credential -> IO (Creds m)) -- ^ How to extract ident. - -> AuthPlugin m + -> (Credential -> IO (Creds master)) -- ^ How to extract ident. + -> AuthPlugin master authOAuth oauth mkCreds = AuthPlugin name dispatch login where name = T.pack $ oauthServerName oauth url = PluginR name [] lookupTokenSecret = bsToText . fromMaybe "" . lookup "oauth_token_secret" . unCredential + + oauthSessionName :: Text oauthSessionName = "__oauth_token_secret" + dispatch + :: ( MonadSubHandler m + , master ~ HandlerSite m + , Auth ~ SubHandlerSite m + , MonadUnliftIO m + ) + => Text + -> [Text] + -> m TypedContent dispatch "GET" ["forward"] = do - render <- lift getUrlRender + render <- getUrlRender tm <- getRouteToParent let oauth' = oauth { oauthCallback = Just $ encodeUtf8 $ render $ tm url } - master <- lift getYesod - tok <- lift $ getTemporaryCredential oauth' (authHttpManager master) + manager <- authHttpManager + tok <- getTemporaryCredential oauth' manager setSession oauthSessionName $ lookupTokenSecret tok redirect $ authorizeUrl oauth' tok - dispatch "GET" [] = lift $ do + dispatch "GET" [] = do Just tokSec <- lookupSession oauthSessionName deleteSession oauthSessionName reqTok <- @@ -72,8 +87,8 @@ authOAuth oauth mkCreds = AuthPlugin name dispatch login , ("oauth_token", encodeUtf8 oaTok) , ("oauth_token_secret", encodeUtf8 tokSec) ] - master <- getYesod - accTok <- getAccessToken oauth reqTok (authHttpManager master) + manager <- authHttpManager + accTok <- getAccessToken oauth reqTok manager creds <- liftIO $ mkCreds accTok setCredsRedirect creds dispatch _ _ = notFound diff --git a/yesod-auth-oauth/yesod-auth-oauth.cabal b/yesod-auth-oauth/yesod-auth-oauth.cabal index c21ac9e1..7c9c55a5 100644 --- a/yesod-auth-oauth/yesod-auth-oauth.cabal +++ b/yesod-auth-oauth/yesod-auth-oauth.cabal @@ -29,6 +29,7 @@ library , yesod-form >= 1.4 && < 1.5 , transformers >= 0.2.2 && < 0.6 , lifted-base >= 0.2 && < 0.3 + , unliftio-core exposed-modules: Yesod.Auth.OAuth ghc-options: -Wall diff --git a/yesod-auth/Yesod/Auth.hs b/yesod-auth/Yesod/Auth.hs index 8c2a4f4c..c5d137e8 100644 --- a/yesod-auth/Yesod/Auth.hs +++ b/yesod-auth/Yesod/Auth.hs @@ -39,6 +39,7 @@ module Yesod.Auth -- * Exception , AuthException (..) -- * Helper + , MonadAuthHandler , AuthHandler -- * Internal , credsKey @@ -49,8 +50,7 @@ module Yesod.Auth import Control.Monad (when) import Control.Monad.Trans.Maybe -import Control.Monad.Trans.Reader (ReaderT) -import Control.Monad.IO.Unlift (withRunInIO) +import Control.Monad.IO.Unlift (withRunInIO, MonadUnliftIO) import Yesod.Auth.Routes import Data.Aeson hiding (json) @@ -78,7 +78,8 @@ import Control.Monad (void) type AuthRoute = Route Auth -type AuthHandler master a = forall m. (MonadSubHandler m, YesodAuth master, master ~ HandlerSite m, Auth ~ SubHandlerSite m) => m a +type MonadAuthHandler master m = (MonadSubHandler 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 @@ -192,8 +193,8 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage -- 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 -> IO Manager - authHttpManager _ = getGlobalManager + authHttpManager :: AuthHandler master Manager + authHttpManager = liftIO getGlobalManager -- | Called on a successful login. By default, calls -- @addMessageI "success" NowLoggedIn@. @@ -232,13 +233,14 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage -- -- 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 :: (MonadSubHandler m, HandlerSite m ~ master, SubHandlerSite m ~ Auth) - => Request - -> (Response BodyReader -> ReaderT (SubsiteData Auth master) (HandlerFor master) a) - -> m a + runHttpRequest + :: MonadAuthHandler master m + => Request + -> (Response BodyReader -> m a) + -> m a runHttpRequest req inner = do - man <- getYesod >>= liftIO . authHttpManager - lift $ withRunInIO $ \run -> withResponse req man $ run . inner + man <- authHttpManager + withRunInIO $ \run -> withResponse req man $ run . inner {-# MINIMAL loginDest, logoutDest, (authenticate | getAuthId), authPlugins, authHttpManager #-} @@ -268,7 +270,8 @@ defaultMaybeAuthId = runMaybeT $ do cachedAuth :: (YesodAuthPersist master, Typeable (AuthEntity master)) - => AuthId master -> AuthHandler master (Maybe (AuthEntity master)) + => AuthId master + -> AuthHandler master (Maybe (AuthEntity master)) cachedAuth = fmap unCachedMaybeAuth . cached @@ -285,25 +288,25 @@ cachedAuth defaultLoginHandler :: AuthHandler master Html defaultLoginHandler = do tp <- getRouteToParent - liftHandler $ authLayout $ do + authLayout $ do setTitleI Msg.LoginTitle master <- getYesod mapM_ (flip apLogin tp) (authPlugins master) -loginErrorMessageI :: (YesodAuth (HandlerSite m), MonadSubHandler m) - => Route (SubHandlerSite m) - -> AuthMessage - -> m TypedContent +loginErrorMessageI + :: Route Auth + -> AuthMessage + -> AuthHandler master TypedContent loginErrorMessageI dest msg = do toParent <- getRouteToParent - liftHandler $ loginErrorMessageMasterI (toParent dest) msg + loginErrorMessageMasterI (toParent dest) msg -loginErrorMessageMasterI :: (YesodAuth master, RenderMessage master AuthMessage) - => Route master - -> AuthMessage - -> AuthHandler master TypedContent +loginErrorMessageMasterI + :: Route master + -> AuthMessage + -> AuthHandler master TypedContent loginErrorMessageMasterI dest msg = do mr <- getMessageRender loginErrorMessage dest (mr msg) @@ -316,19 +319,22 @@ loginErrorMessage :: YesodAuth master -> AuthHandler master TypedContent loginErrorMessage dest msg = messageJson401 msg (onErrorHtml dest msg) -messageJson401 :: (MonadSubHandler m, HandlerSite m ~ master, SubHandlerSite m ~ Auth) - => Text - -> m Html - -> m TypedContent +messageJson401 + :: MonadAuthHandler master m + => Text + -> m Html + -> m TypedContent messageJson401 = messageJsonStatus unauthorized401 -messageJson500 :: Text -> HandlerFor master Html -> HandlerFor master TypedContent +messageJson500 :: MonadAuthHandler master m => Text -> m Html -> m TypedContent messageJson500 = messageJsonStatus internalServerError500 -messageJsonStatus :: Status - -> Text - -> HandlerFor master Html - -> HandlerFor master TypedContent +messageJsonStatus + :: MonadAuthHandler master m + => Status + -> Text + -> m Html + -> m TypedContent messageJsonStatus status msg html = selectRep $ do provideRep html provideRep $ do @@ -340,9 +346,9 @@ provideJsonMessage :: Monad m => Text -> Writer.Writer (Endo [ProvidedRep m]) () provideJsonMessage msg = provideRep $ return $ object ["message" .= msg] -setCredsRedirect :: YesodAuth master - => Creds master -- ^ new credentials - -> HandlerFor master TypedContent +setCredsRedirect + :: Creds master -- ^ new credentials + -> AuthHandler master TypedContent setCredsRedirect creds = do y <- getYesod auth <- authenticate creds @@ -381,10 +387,9 @@ setCredsRedirect creds = do 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 - -> HandlerFor master () + -> AuthHandler master () setCreds doRedirects creds = if doRedirects then void $ setCredsRedirect creds @@ -394,10 +399,11 @@ setCreds doRedirects creds = _ -> return () -- | same as defaultLayoutJson, but uses authLayout -authLayoutJson :: (YesodAuth site, ToJSON j) - => WidgetFor site () -- ^ HTML - -> HandlerFor site j -- ^ JSON - -> HandlerFor site 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 @@ -405,18 +411,17 @@ authLayoutJson w json = selectRep $ do -- | Clears current user credentials for the session. -- -- Since 1.1.7 -clearCreds :: (MonadHandler m, YesodAuth (HandlerSite m)) - => Bool -- ^ if HTTP redirect to 'logoutDest' should be done - -> m () +clearCreds :: Bool -- ^ if HTTP redirect to 'logoutDest' should be done + -> AuthHandler master () clearCreds doRedirects = do y <- getYesod - liftHandler onLogout + onLogout deleteSession credsKey when doRedirects $ do redirectUltDest $ logoutDest y getCheckR :: AuthHandler master TypedContent -getCheckR = liftHandler $ do +getCheckR = do creds <- maybeAuthId authLayoutJson (do setTitle "Authentication Status" @@ -437,7 +442,7 @@ $nothing ] setUltDestReferer' :: AuthHandler master () -setUltDestReferer' = liftHandler $ do +setUltDestReferer' = do master <- getYesod when (redirectToReferer master) setUltDestReferer @@ -471,17 +476,16 @@ maybeAuth :: ( YesodAuthPersist master , Key val ~ AuthId master , PersistEntity val , Typeable val - ) => HandlerFor master (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)) - => HandlerFor master (Maybe (AuthId master, AuthEntity master)) +maybeAuthPair + :: (YesodAuthPersist master, Typeable (AuthEntity master)) + => AuthHandler master (Maybe (AuthId master, AuthEntity master)) maybeAuthPair = runMaybeT $ do aid <- MaybeT maybeAuthId ae <- MaybeT $ cachedAuth aid @@ -512,9 +516,8 @@ class (YesodAuth master, YesodPersist master) => YesodAuthPersist master where type AuthEntity master :: * type AuthEntity master = KeyEntity (AuthId master) - getAuthEntity :: AuthId master -> HandlerFor master (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 @@ -522,16 +525,6 @@ class (YesodAuth master, YesodPersist master) => YesodAuthPersist master where , PersistStore backend ) => AuthId master -> HandlerFor master (Maybe (AuthEntity master)) -#else - default getAuthEntity - :: ( YesodPersistBackend master - ~ PersistEntityBackend (AuthEntity master) - , Key (AuthEntity master) ~ AuthId master - , PersistStore (YesodPersistBackend master) - , PersistEntity (AuthEntity master) - ) - => AuthId master -> HandlerFor master (Maybe (AuthEntity master)) -#endif getAuthEntity = runDB . get @@ -542,7 +535,7 @@ type instance KeyEntity (Key x) = x -- authenticated or responds with error 401 if this is an API client (expecting JSON). -- -- Since 1.1.0 -requireAuthId :: YesodAuth master => HandlerFor master (AuthId master) +requireAuthId :: AuthHandler master (AuthId master) requireAuthId = maybeAuthId >>= maybe handleAuthLack return -- | Similar to 'maybeAuth', but redirects to a login page if user is not @@ -554,23 +547,26 @@ requireAuth :: ( YesodAuthPersist master , Key val ~ AuthId master , PersistEntity val , Typeable val - ) => HandlerFor master (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)) - => HandlerFor master (AuthId master, AuthEntity master) +requireAuthPair + :: ( YesodAuthPersist master + , Typeable (AuthEntity master) + ) + => AuthHandler master (AuthId master, AuthEntity master) requireAuthPair = maybeAuthPair >>= maybe handleAuthLack return -handleAuthLack :: YesodAuth master => HandlerFor master a +handleAuthLack :: AuthHandler master a handleAuthLack = do aj <- acceptsJson if aj then notAuthenticated else redirectLogin -redirectLogin :: YesodAuth master => HandlerFor master a +redirectLogin :: AuthHandler master a redirectLogin = do y <- getYesod when (redirectToCurrent y) setUltDestCurrent @@ -586,7 +582,7 @@ data AuthException = InvalidFacebookResponse instance Exception AuthException -- FIXME HandlerSite m ~ SubHandlerSite m should be unnecessary -instance (YesodAuth (HandlerSite m), HandlerSite m ~ SubHandlerSite m, MonadSubHandler m) => YesodSubDispatch Auth m where +instance (YesodAuth (HandlerSite m), HandlerSite m ~ SubHandlerSite m, MonadSubHandler m, MonadUnliftIO m) => YesodSubDispatch Auth m where yesodSubDispatch = $(mkYesodSubDispatch resourcesAuth) asHtml :: Html -> Html diff --git a/yesod-auth/Yesod/Auth/BrowserId.hs b/yesod-auth/Yesod/Auth/BrowserId.hs index 802cba03..87dce2dc 100644 --- a/yesod-auth/Yesod/Auth/BrowserId.hs +++ b/yesod-auth/Yesod/Auth/BrowserId.hs @@ -70,7 +70,6 @@ authBrowserId bis@BrowserIdSettings {..} = AuthPlugin , apDispatch = \m ps -> case (m, ps) of ("GET", [assertion]) -> do - master <- getYesod audience <- case bisAudience of Just a -> return a @@ -78,13 +77,14 @@ authBrowserId bis@BrowserIdSettings {..} = AuthPlugin r <- getUrlRender tm <- getRouteToParent return $ T.takeWhile (/= '/') $ stripScheme $ r $ tm LoginR - memail <- liftHandler $ checkAssertion audience assertion (authHttpManager master) + manager <- authHttpManager + memail <- liftResourceT $ checkAssertion audience assertion manager case memail of Nothing -> do $logErrorS "yesod-auth" "BrowserID assertion failure" tm <- getRouteToParent - liftHandler $ loginErrorMessage (tm LoginR) "BrowserID login error." - Just email -> liftHandler $ setCredsRedirect Creds + loginErrorMessage (tm LoginR) "BrowserID login error." + Just email -> setCredsRedirect Creds { credsPlugin = pid , credsIdent = email , credsExtra = [] @@ -117,7 +117,7 @@ $newline never 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 @@ -166,5 +166,5 @@ createOnClickOverride BrowserIdSettings {..} toMaster mOnRegistration = do -- name. createOnClick :: BrowserIdSettings -> (Route Auth -> Route master) - -> WidgetT master IO Text + -> WidgetFor master Text createOnClick bidSettings toMaster = createOnClickOverride bidSettings toMaster Nothing diff --git a/yesod-auth/Yesod/Auth/Dummy.hs b/yesod-auth/Yesod/Auth/Dummy.hs index 4899f99d..721d6311 100644 --- a/yesod-auth/Yesod/Auth/Dummy.hs +++ b/yesod-auth/Yesod/Auth/Dummy.hs @@ -1,6 +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,7 +17,7 @@ authDummy :: YesodAuth m => AuthPlugin m authDummy = AuthPlugin "dummy" dispatch login where - dispatch "POST" [] = liftHandler $ do + dispatch "POST" [] = do ident <- runInputPost $ ireq textField "ident" setCredsRedirect $ Creds "dummy" ident [] dispatch _ _ = notFound diff --git a/yesod-auth/Yesod/Auth/Email.hs b/yesod-auth/Yesod/Auth/Email.hs index 60b65fb7..38afc51e 100644 --- a/yesod-auth/Yesod/Auth/Email.hs +++ b/yesod-auth/Yesod/Auth/Email.hs @@ -186,29 +186,29 @@ class ( YesodAuth site -- 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 @@ class ( YesodAuth site -- 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 @@ class ( YesodAuth site -- See . -- -- @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 @@ class ( YesodAuth site -- 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 @@ class ( YesodAuth site -- | 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 @@ class ( YesodAuth site -- | 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 @@ class ( YesodAuth site -- Default: 'defaultEmailLoginHandler'. -- -- @since 1.4.17 - emailLoginHandler :: (Route Auth -> Route site) -> WidgetT site IO () + emailLoginHandler :: (Route Auth -> Route site) -> WidgetFor site () emailLoginHandler = defaultEmailLoginHandler @@ -377,9 +377,12 @@ 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|
@@ -439,9 +442,9 @@ defaultEmailLoginHandler toParent = do -- @since 1.2.6 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|

_{Msg.EnterEmail} @@ -482,12 +485,12 @@ registerHelper :: YesodAuthEmail master -> Route Auth -> 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,28 +505,29 @@ registerHelper allowUsername dest = do 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 => AuthHandler master TypedContent postRegisterR = registerHelper False registerR @@ -536,9 +540,9 @@ getForgotPasswordR = forgotPasswordHandler -- @since 1.2.6 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|

_{Msg.PasswordResetPrompt} @@ -577,27 +581,28 @@ getVerifyR :: YesodAuthEmail site -> Text -> 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 @@ -614,14 +619,14 @@ parseCreds = withObject "creds" (\obj -> do 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 @@ postLoginR = do 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 @@ postLoginR = do 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')] @@ -660,11 +665,11 @@ postLoginR = do 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'. @@ -672,12 +677,12 @@ getPasswordR = do -- @since 1.2.6 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|

_{Msg.SetPass} @@ -751,8 +756,8 @@ parsePassword = withObject "password" (\obj -> do 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 @@ postPasswordR = do 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, _) -> - liftHandler $ 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 <- liftHandler $ verifyPassword current' realpass + passValid <- verifyPassword current' realpass if passValid then confirmPassword aid tm jcreds - else liftHandler $ 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 @@ postPasswordR = do 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 @@ postPasswordR = do 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 diff --git a/yesod-auth/Yesod/Auth/GoogleEmail.hs b/yesod-auth/Yesod/Auth/GoogleEmail.hs deleted file mode 100644 index eb0b6cee..00000000 --- a/yesod-auth/Yesod/Auth/GoogleEmail.hs +++ /dev/null @@ -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|_{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" diff --git a/yesod-auth/Yesod/Auth/GoogleEmail2.hs b/yesod-auth/Yesod/Auth/GoogleEmail2.hs index 577e86a7..01a00e3c 100644 --- a/yesod-auth/Yesod/Auth/GoogleEmail2.hs +++ b/yesod-auth/Yesod/Auth/GoogleEmail2.hs @@ -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,12 +56,12 @@ import Yesod.Auth (Auth, AuthPlugin (AuthPlugin), 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, @@ -187,10 +189,10 @@ authPlugin storeToken clientID clientSecret = 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 @@ authPlugin storeToken clientID clientSecret = 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,15 +256,12 @@ authPlugin storeToken clientID clientSecret = [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 $ +makeHttpRequest :: Request -> AuthHandler site A.Value +makeHttpRequest req = runHttpRequest req $ \res -> bodyReaderSource (responseBody res) $$ sinkParser json' -- | Allows to fetch information about a user from Google's API. @@ -273,7 +269,7 @@ makeHttpRequest req = lift $ -- 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 -> AuthHandler site (Maybe Person) getPerson manager token = parseMaybe parseJSON <$> (do req <- personValueRequest token res <- http req manager @@ -282,13 +278,8 @@ getPerson manager token = parseMaybe parseJSON <$> (do 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) diff --git a/yesod-auth/Yesod/Auth/Hardcoded.hs b/yesod-auth/Yesod/Auth/Hardcoded.hs index 9421feb4..cb5ec199 100644 --- a/yesod-auth/Yesod/Auth/Hardcoded.hs +++ b/yesod-auth/Yesod/Auth/Hardcoded.hs @@ -131,9 +131,10 @@ module Yesod.Auth.Hardcoded , 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 @@ loginR = PluginR "hardcoded" ["login"] 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 @@ authHardcoded = |] -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 diff --git a/yesod-auth/Yesod/Auth/OpenId.hs b/yesod-auth/Yesod/Auth/OpenId.hs index f32ff747..f65bed7c 100644 --- a/yesod-auth/Yesod/Auth/OpenId.hs +++ b/yesod-auth/Yesod/Auth/OpenId.hs @@ -3,6 +3,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GADTs #-} module Yesod.Auth.OpenId ( authOpenId , forwardUrl @@ -36,7 +37,10 @@ authOpenId idType extensionFields = 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,18 +61,20 @@ $newline never |] + + 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 <- liftResourceT $ try $ OpenId.getForwardUrl oid complete' Nothing extensionFields manager case eres of Left err -> do - tm <- getRouteToParent - lift $ loginErrorMessage (tm LoginR) $ T.pack $ + loginErrorMessage (tm LoginR) $ T.pack $ show (err :: SomeException) Right x -> redirect x Nothing -> loginErrorMessageI LoginR Msg.NoOpenID @@ -84,13 +90,13 @@ $newline never completeHelper :: IdentifierType -> [(Text, Text)] -> AuthHandler master TypedContent completeHelper idType gets' = do - master <- lift getYesod - eres <- try $ OpenId.authenticateClaimed gets' (authHttpManager master) + manager <- authHttpManager + eres <- liftResourceT $ try $ OpenId.authenticateClaimed gets' manager either onFailure onSuccess eres where onFailure err = do tm <- getRouteToParent - lift $ loginErrorMessage (tm LoginR) $ T.pack $ + loginErrorMessage (tm LoginR) $ T.pack $ show (err :: SomeException) onSuccess oir = do let claimed = @@ -105,7 +111,7 @@ completeHelper idType gets' = do 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 diff --git a/yesod-auth/Yesod/Auth/Rpxnow.hs b/yesod-auth/Yesod/Auth/Rpxnow.hs index 58456cda..8ff663e5 100644 --- a/yesod-auth/Yesod/Auth/Rpxnow.hs +++ b/yesod-auth/Yesod/Auth/Rpxnow.hs @@ -2,6 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} module Yesod.Auth.Rpxnow ( authRpxnow ) where @@ -17,10 +18,10 @@ import Data.Text.Encoding.Error (lenientDecode) 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,17 @@ authRpxnow app apiKey = $newline never