diff --git a/Yesod/Auth.hs b/Yesod/Auth.hs --- a/Yesod/Auth.hs +++ b/Yesod/Auth.hs @@ -59,41 +59,41 @@ type Method = Text type Piece = Text -data AuthPlugin m = AuthPlugin +data AuthPlugin master = AuthPlugin { apName :: Text - , apDispatch :: Method -> [Piece] -> GHandler Auth m () - , apLogin :: forall s. (Route Auth -> Route m) -> GWidget s m () + , apDispatch :: Method -> [Piece] -> GHandler Auth master () + , apLogin :: forall sub. (Route Auth -> Route master) -> GWidget sub master () } getAuth :: a -> Auth getAuth = const Auth -- | User credentials -data Creds m = Creds +data Creds master = Creds { credsPlugin :: Text -- ^ How the user was authenticated , credsIdent :: Text -- ^ Identifier. Exact meaning depends on plugin. , credsExtra :: [(Text, Text)] } -class (Yesod m, PathPiece (AuthId m), RenderMessage m FormMessage) => YesodAuth m where - type AuthId m +class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage) => YesodAuth master where + type AuthId master -- | Default destination on successful login, if no other -- destination exists. - loginDest :: m -> Route m + loginDest :: master -> Route master -- | Default destination on successful logout, if no other -- destination exists. - logoutDest :: m -> Route m + logoutDest :: master -> Route master -- | Determine the ID associated with the set of credentials. - getAuthId :: Creds m -> GHandler s m (Maybe (AuthId m)) + getAuthId :: Creds master -> GHandler sub master (Maybe (AuthId master)) -- | Which authentication backends to use. - authPlugins :: m -> [AuthPlugin m] + authPlugins :: master -> [AuthPlugin master] -- | What to show on the login page. - loginHandler :: GHandler Auth m RepHtml + loginHandler :: GHandler Auth master RepHtml loginHandler = defaultLayout $ do setTitleI Msg.LoginTitle tm <- lift getRouteToMaster @@ -101,29 +101,29 @@ mapM_ (flip apLogin tm) (authPlugins master) -- | Used for i18n of messages provided by this package. - renderAuthMessage :: m + renderAuthMessage :: master -> [Text] -- ^ languages -> AuthMessage -> Text renderAuthMessage _ _ = defaultMessage -- | After login and logout, redirect to the referring page, instead of -- 'loginDest' and 'logoutDest'. Default is 'False'. - redirectToReferer :: m -> Bool + redirectToReferer :: master -> Bool redirectToReferer _ = False -- | Return an HTTP connection manager that is stored in the foundation -- 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 :: m -> Manager + authHttpManager :: master -> Manager -- | Called on a successful login. By default, calls -- @setMessageI NowLoggedIn@. - onLogin :: GHandler s m () + onLogin :: GHandler sub master () onLogin = setMessageI Msg.NowLoggedIn -- | Called on logout. By default, does nothing - onLogout :: GHandler s m () + onLogout :: GHandler sub master () onLogout = return () -- | Retrieves user credentials, if user is authenticated. @@ -135,7 +135,7 @@ -- other than a browser. -- -- Since 1.1.2 - maybeAuthId :: GHandler s m (Maybe (AuthId m)) + maybeAuthId :: GHandler sub master (Maybe (AuthId master)) maybeAuthId = defaultMaybeAuthId credsKey :: Text @@ -144,7 +144,8 @@ -- | Retrieves user credentials from the session, if user is authenticated. -- -- Since 1.1.2 -defaultMaybeAuthId :: YesodAuth m => GHandler s m (Maybe (AuthId m)) +defaultMaybeAuthId :: YesodAuth master + => GHandler sub master (Maybe (AuthId master)) defaultMaybeAuthId = do ms <- lookupSession credsKey case ms of @@ -162,8 +163,7 @@ /page/#Text/STRINGS PluginR |] --- | FIXME: won't show up till redirect -setCreds :: YesodAuth m => Bool -> Creds m -> GHandler s m () +setCreds :: YesodAuth master => Bool -> Creds master -> GHandler sub master () setCreds doRedirects creds = do y <- getYesod maid <- getAuthId creds @@ -184,7 +184,7 @@ onLogin redirectUltDest $ loginDest y -getCheckR :: YesodAuth m => GHandler Auth m RepHtmlJson +getCheckR :: YesodAuth master => GHandler Auth master RepHtmlJson getCheckR = do creds <- maybeAuthId defaultLayoutJson (do @@ -207,23 +207,25 @@ setUltDestReferer' :: YesodAuth master => GHandler sub master () setUltDestReferer' = do - m <- getYesod - when (redirectToReferer m) setUltDestReferer + master <- getYesod + when (redirectToReferer master) setUltDestReferer -getLoginR :: YesodAuth m => GHandler Auth m RepHtml +getLoginR :: YesodAuth master => GHandler Auth master RepHtml getLoginR = setUltDestReferer' >> loginHandler -getLogoutR :: YesodAuth m => GHandler Auth m () -getLogoutR = setUltDestReferer' >> postLogoutR -- FIXME redirect to post +getLogoutR :: YesodAuth master => GHandler Auth master () +getLogoutR = do + tm <- getRouteToMaster + setUltDestReferer' >> redirectToPost (tm LogoutR) -postLogoutR :: YesodAuth m => GHandler Auth m () +postLogoutR :: YesodAuth master => GHandler Auth master () postLogoutR = do y <- getYesod deleteSession credsKey onLogout redirectUltDest $ logoutDest y -handlePluginR :: YesodAuth m => Text -> [Text] -> GHandler Auth m () +handlePluginR :: YesodAuth master => Text -> [Text] -> GHandler Auth master () handlePluginR plugin pieces = do master <- getYesod env <- waiRequest @@ -232,46 +234,46 @@ [] -> notFound ap:_ -> apDispatch ap method pieces -maybeAuth :: ( YesodAuth m +maybeAuth :: ( YesodAuth master #if MIN_VERSION_persistent(1, 1, 0) - , PersistMonadBackend (b (GHandler s m)) ~ PersistEntityBackend val - , b ~ YesodPersistBackend m - , Key val ~ AuthId m - , PersistStore (b (GHandler s m)) + , PersistMonadBackend (b (GHandler sub master)) ~ PersistEntityBackend val + , b ~ YesodPersistBackend master + , Key val ~ AuthId master + , PersistStore (b (GHandler sub master)) #else - , b ~ YesodPersistBackend m + , b ~ YesodPersistBackend master , b ~ PersistEntityBackend val - , Key b val ~ AuthId m - , PersistStore b (GHandler s m) + , Key b val ~ AuthId master + , PersistStore b (GHandler sub master) #endif , PersistEntity val - , YesodPersist m - ) => GHandler s m (Maybe (Entity val)) + , YesodPersist master + ) => GHandler sub master (Maybe (Entity val)) maybeAuth = runMaybeT $ do aid <- MaybeT $ maybeAuthId a <- MaybeT $ runDB $ get aid return $ Entity aid a -requireAuthId :: YesodAuth m => GHandler s m (AuthId m) +requireAuthId :: YesodAuth master => GHandler sub master (AuthId master) requireAuthId = maybeAuthId >>= maybe redirectLogin return -requireAuth :: ( YesodAuth m - , b ~ YesodPersistBackend m +requireAuth :: ( YesodAuth master + , b ~ YesodPersistBackend master #if MIN_VERSION_persistent(1, 1, 0) - , PersistMonadBackend (b (GHandler s m)) ~ PersistEntityBackend val - , Key val ~ AuthId m - , PersistStore (b (GHandler s m)) + , PersistMonadBackend (b (GHandler sub master)) ~ PersistEntityBackend val + , Key val ~ AuthId master + , PersistStore (b (GHandler sub master)) #else , b ~ PersistEntityBackend val - , Key b val ~ AuthId m - , PersistStore b (GHandler s m) + , Key b val ~ AuthId master + , PersistStore b (GHandler sub master) #endif , PersistEntity val - , YesodPersist m - ) => GHandler s m (Entity val) + , YesodPersist master + ) => GHandler sub master (Entity val) requireAuth = maybeAuth >>= maybe redirectLogin return -redirectLogin :: Yesod m => GHandler s m a +redirectLogin :: Yesod master => GHandler sub master a redirectLogin = do y <- getYesod setUltDestCurrent @@ -279,7 +281,7 @@ Just z -> redirect z Nothing -> permissionDenied "Please configure authRoute" -instance YesodAuth m => RenderMessage m AuthMessage where +instance YesodAuth master => RenderMessage master AuthMessage where renderMessage = renderAuthMessage data AuthException = InvalidBrowserIDAssertion diff --git a/Yesod/Auth/Rpxnow.hs b/Yesod/Auth/Rpxnow.hs --- a/Yesod/Auth/Rpxnow.hs +++ b/Yesod/Auth/Rpxnow.hs @@ -13,7 +13,10 @@ import Yesod.Request import Text.Hamlet (hamlet) import Data.Text (pack, unpack) +import Data.Text.Encoding (encodeUtf8, decodeUtf8With) +import Data.Text.Encoding.Error (lenientDecode) import Control.Arrow ((***)) +import Network.HTTP.Types (renderQuery) authRpxnow :: YesodAuth m => String -- ^ app name @@ -23,10 +26,12 @@ AuthPlugin "rpxnow" dispatch login where login tm = do - let url = {- FIXME urlEncode $ -} tm $ PluginR "rpxnow" [] + render <- lift getUrlRender + let queryString = decodeUtf8With lenientDecode + $ renderQuery True [("token_url", Just $ encodeUtf8 $ render $ tm $ PluginR "rpxnow" [])] toWidget [hamlet| $newline never -