diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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) diff --git a/Yesod/Auth.hs b/Yesod/Auth.hs --- a/Yesod/Auth.hs +++ b/Yesod/Auth.hs @@ -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 diff --git a/Yesod/Auth/BrowserId.hs b/Yesod/Auth/BrowserId.hs --- a/Yesod/Auth/BrowserId.hs +++ b/Yesod/Auth/BrowserId.hs @@ -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 diff --git a/Yesod/Auth/Dummy.hs b/Yesod/Auth/Dummy.hs --- a/Yesod/Auth/Dummy.hs +++ b/Yesod/Auth/Dummy.hs @@ -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 diff --git a/Yesod/Auth/Email.hs b/Yesod/Auth/Email.hs --- a/Yesod/Auth/Email.hs +++ b/Yesod/Auth/Email.hs @@ -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 . -- -- @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|
@@ -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|

_{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|

_{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|

_{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 diff --git a/Yesod/Auth/GoogleEmail.hs b/Yesod/Auth/GoogleEmail.hs deleted file mode 100644 --- a/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/GoogleEmail2.hs b/Yesod/Auth/GoogleEmail2.hs --- a/Yesod/Auth/GoogleEmail2.hs +++ b/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,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) diff --git a/Yesod/Auth/Hardcoded.hs b/Yesod/Auth/Hardcoded.hs --- a/Yesod/Auth/Hardcoded.hs +++ b/Yesod/Auth/Hardcoded.hs @@ -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 diff --git a/Yesod/Auth/OpenId.hs b/Yesod/Auth/OpenId.hs --- a/Yesod/Auth/OpenId.hs +++ b/Yesod/Auth/OpenId.hs @@ -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 @@ |] + + 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 diff --git a/Yesod/Auth/Rpxnow.hs b/Yesod/Auth/Rpxnow.hs --- a/Yesod/Auth/Rpxnow.hs +++ b/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 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