diff --git a/yesod-auth/Yesod/Auth.hs b/yesod-auth/Yesod/Auth.hs index c5b1c163..8c2a4f4c 100644 --- a/yesod-auth/Yesod/Auth.hs +++ b/yesod-auth/Yesod/Auth.hs @@ -47,9 +47,10 @@ module Yesod.Auth , asHtml ) where -import Control.Applicative ((<$>)) import Control.Monad (when) import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Reader (ReaderT) +import Control.Monad.IO.Unlift (withRunInIO) import Yesod.Auth.Routes import Data.Aeson hiding (json) @@ -60,11 +61,11 @@ import qualified Data.Text as T 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 (HandlerFor(..)) import Yesod.Persist import Yesod.Auth.Message (AuthMessage, defaultMessage) import qualified Yesod.Auth.Message as Msg @@ -110,8 +111,8 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage type AuthId master -- | specify the layout. Uses defaultLayout by default - authLayout :: WidgetFor master () -> HandlerFor master Html - authLayout = defaultLayout + authLayout :: WidgetFor master () -> AuthHandler master Html + authLayout = liftHandler . defaultLayout -- | Default destination on successful login, if no other -- destination exists. @@ -126,7 +127,7 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage -- Default implementation is in terms of @'getAuthId'@ -- -- Since: 1.4.4 - authenticate :: Creds master -> HandlerFor master (AuthenticationResult master) + authenticate :: Creds master -> AuthHandler master (AuthenticationResult master) authenticate creds = do muid <- getAuthId creds @@ -136,7 +137,7 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage -- -- Default implementation is in terms of @'authenticate'@ -- - getAuthId :: Creds master -> HandlerFor master (Maybe (AuthId master)) + getAuthId :: Creds master -> AuthHandler master (Maybe (AuthId master)) getAuthId creds = do auth <- authenticate creds @@ -191,15 +192,16 @@ 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 -> Manager + authHttpManager :: master -> IO Manager + authHttpManager _ = getGlobalManager -- | Called on a successful login. By default, calls -- @addMessageI "success" NowLoggedIn@. - onLogin :: HandlerFor master () + onLogin :: AuthHandler master () onLogin = addMessageI "success" Msg.NowLoggedIn -- | Called on logout. By default, does nothing - onLogout :: HandlerFor master () + onLogout :: AuthHandler master () onLogout = return () -- | Retrieves user credentials, if user is authenticated. @@ -211,16 +213,16 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage -- other than a browser. -- -- Since 1.2.0 - maybeAuthId :: HandlerFor master (Maybe (AuthId master)) + maybeAuthId :: AuthHandler master (Maybe (AuthId master)) default maybeAuthId :: (YesodAuthPersist master, Typeable (AuthEntity master)) - => HandlerFor master (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 :: Route master -> Text -> HandlerFor master Html + onErrorHtml :: Route master -> Text -> AuthHandler master Html onErrorHtml dest msg = do addMessage "error" $ toHtml msg fmap asHtml $ redirect dest @@ -230,10 +232,13 @@ 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 :: Request -> (Response BodyReader -> HandlerFor master a) -> HandlerFor master a + runHttpRequest :: (MonadSubHandler m, HandlerSite m ~ master, SubHandlerSite m ~ Auth) + => Request + -> (Response BodyReader -> ReaderT (SubsiteData Auth master) (HandlerFor master) a) + -> m a runHttpRequest req inner = do - man <- authHttpManager Control.Applicative.<$> getYesod - HandlerFor $ \t -> withResponse req man $ \res -> unHandlerFor (inner res) t + man <- getYesod >>= liftIO . authHttpManager + lift $ withRunInIO $ \run -> withResponse req man $ run . inner {-# MINIMAL loginDest, logoutDest, (authenticate | getAuthId), authPlugins, authHttpManager #-} @@ -254,7 +259,7 @@ credsKey = "_ID" -- Since 1.1.2 defaultMaybeAuthId :: (YesodAuthPersist master, Typeable (AuthEntity master)) - => HandlerFor master (Maybe (AuthId master)) + => AuthHandler master (Maybe (AuthId master)) defaultMaybeAuthId = runMaybeT $ do s <- MaybeT $ lookupSession credsKey aid <- MaybeT $ return $ fromPathPiece s @@ -263,7 +268,7 @@ defaultMaybeAuthId = runMaybeT $ do cachedAuth :: (YesodAuthPersist master, Typeable (AuthEntity master)) - => AuthId master -> HandlerFor master (Maybe (AuthEntity master)) + => AuthId master -> AuthHandler master (Maybe (AuthEntity master)) cachedAuth = fmap unCachedMaybeAuth . cached @@ -298,7 +303,7 @@ loginErrorMessageI dest msg = do loginErrorMessageMasterI :: (YesodAuth master, RenderMessage master AuthMessage) => Route master -> AuthMessage - -> HandlerFor master TypedContent + -> AuthHandler master TypedContent loginErrorMessageMasterI dest msg = do mr <- getMessageRender loginErrorMessage dest (mr msg) @@ -308,10 +313,13 @@ loginErrorMessageMasterI dest msg = do loginErrorMessage :: YesodAuth master => Route master -> Text - -> HandlerFor master TypedContent + -> AuthHandler master TypedContent loginErrorMessage dest msg = messageJson401 msg (onErrorHtml dest msg) -messageJson401 :: Text -> HandlerFor master Html -> HandlerFor master TypedContent +messageJson401 :: (MonadSubHandler m, HandlerSite m ~ master, SubHandlerSite m ~ Auth) + => Text + -> m Html + -> m TypedContent messageJson401 = messageJsonStatus unauthorized401 messageJson500 :: Text -> HandlerFor master Html -> HandlerFor master TypedContent @@ -577,8 +585,8 @@ data AuthException = InvalidFacebookResponse deriving (Show, Typeable) instance Exception AuthException --- FIXME this is ugly, and I probably want to ditch the MonadSubHandler typeclass anyway -instance (YesodAuth (HandlerSite m), MonadSubHandler m) => YesodSubDispatch Auth m where +-- FIXME HandlerSite m ~ SubHandlerSite m should be unnecessary +instance (YesodAuth (HandlerSite m), HandlerSite m ~ SubHandlerSite m, MonadSubHandler m) => YesodSubDispatch Auth m where yesodSubDispatch = $(mkYesodSubDispatch resourcesAuth) asHtml :: Html -> Html diff --git a/yesod-auth/Yesod/Auth/Dummy.hs b/yesod-auth/Yesod/Auth/Dummy.hs index 9e4611d6..4899f99d 100644 --- a/yesod-auth/Yesod/Auth/Dummy.hs +++ b/yesod-auth/Yesod/Auth/Dummy.hs @@ -1,5 +1,6 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} -- | 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. @@ -15,9 +16,9 @@ authDummy :: YesodAuth m => AuthPlugin m authDummy = AuthPlugin "dummy" dispatch login where - dispatch "POST" [] = do - ident <- lift $ runInputPost $ ireq textField "ident" - lift $ setCredsRedirect $ Creds "dummy" ident [] + dispatch "POST" [] = liftHandler $ do + ident <- runInputPost $ ireq textField "ident" + setCredsRedirect $ Creds "dummy" ident [] dispatch _ _ = notFound url = PluginR "dummy" [] login authToMaster = do diff --git a/yesod-auth/Yesod/Auth/Email.hs b/yesod-auth/Yesod/Auth/Email.hs index 51cbea7c..60b65fb7 100644 --- a/yesod-auth/Yesod/Auth/Email.hs +++ b/yesod-auth/Yesod/Auth/Email.hs @@ -325,7 +325,7 @@ class ( YesodAuth site -- 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 @@ class ( YesodAuth site -- 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 @@ class ( YesodAuth site -- 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,7 +371,7 @@ authEmail = 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'. @@ -437,7 +437,7 @@ defaultEmailLoginHandler toParent = do -- | 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 toParentRoute <- getRouteToParent @@ -480,7 +480,7 @@ parseEmail = withObject "email" (\obj -> do registerHelper :: YesodAuthEmail master => Bool -- ^ allow usernames? -> Route Auth - -> HandlerT Auth (HandlerT master IO) TypedContent + -> AuthHandler master TypedContent registerHelper allowUsername dest = do y <- lift getYesod checkCsrfHeaderOrParam defaultCsrfHeaderName defaultCsrfParamName @@ -525,16 +525,16 @@ registerHelper allowUsername dest = do lift $ sendVerifyEmail email verKey verUrl lift $ 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 toParent <- getRouteToParent @@ -569,13 +569,13 @@ defaultForgotPasswordHandler = do 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 @@ -612,7 +612,7 @@ parseCreds = withObject "creds" (\obj -> do return (email', pass)) -postLoginR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent +postLoginR :: YesodAuthEmail master => AuthHandler master TypedContent postLoginR = do result <- lift $ runInputPostResult $ (,) <$> ireq textField "email" @@ -658,7 +658,7 @@ postLoginR = do 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 case maid of @@ -670,7 +670,7 @@ getPasswordR = do -- | 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 toParent <- getRouteToParent @@ -749,7 +749,7 @@ parsePassword = withObject "password" (\obj -> do 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 @@ -773,14 +773,14 @@ postPasswordR = do mrealpass <- lift $ getPassword aid case (mrealpass, current) of (Nothing, _) -> - lift $ loginErrorMessage (tm setpassR) "You do not currently have a password set on your account" + liftHandler $ 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 <- liftHandler $ verifyPassword current' realpass if passValid then confirmPassword aid tm jcreds - else lift $ loginErrorMessage (tm setpassR) "Invalid current password, please try again" + else liftHandler $ loginErrorMessage (tm setpassR) "Invalid current password, please try again" where msgOk = Msg.PassUpdated diff --git a/yesod-auth/yesod-auth.cabal b/yesod-auth/yesod-auth.cabal index 1de994a2..2adcfa49 100644 --- a/yesod-auth/yesod-auth.cabal +++ b/yesod-auth/yesod-auth.cabal @@ -41,6 +41,7 @@ library , persistent >= 2.1 && < 2.8 , persistent-template >= 2.1 && < 2.8 , http-client + , http-client-tls , http-conduit >= 2.1 , aeson >= 0.7 , lifted-base >= 0.1 @@ -61,6 +62,7 @@ library , conduit , conduit-extra , nonce >= 1.0.2 && < 1.1 + , unliftio-core if flag(network-uri) build-depends: network-uri >= 2.6 diff --git a/yesod-core/Yesod/Core.hs b/yesod-core/Yesod/Core.hs index d13d5cf4..fdcb7c43 100644 --- a/yesod-core/Yesod/Core.hs +++ b/yesod-core/Yesod/Core.hs @@ -76,6 +76,7 @@ module Yesod.Core , getApprootText -- * Subsites , MonadSubHandler (..) + , SubsiteData -- * Misc , yesodVersion , yesodRender