Not logged in.
|]
jsonCreds creds =
- Object $ Map.fromList
+ toJSON $ Map.fromList
[ (T.pack "logged_in", Bool $ maybe False (const True) creds)
]
-setUltDestReferer' :: YesodAuth master => GHandler sub master ()
+setUltDestReferer' :: (MonadHandler m, YesodAuth (HandlerSite m)) => m ()
setUltDestReferer' = do
master <- getYesod
when (redirectToReferer master) setUltDestReferer
-getLoginR :: YesodAuth master => GHandler Auth master RepHtml
+getLoginR :: AuthHandler master Html
getLoginR = setUltDestReferer' >> loginHandler
-getLogoutR :: YesodAuth master => GHandler Auth master ()
+getLogoutR :: AuthHandler master ()
getLogoutR = do
- tm <- getRouteToMaster
- setUltDestReferer' >> redirectToPost (tm LogoutR)
+ tp <- getRouteToParent
+ setUltDestReferer' >> redirectToPost (tp LogoutR)
-postLogoutR :: YesodAuth master => GHandler Auth master ()
+postLogoutR :: AuthHandler master ()
postLogoutR = clearCreds True
-handlePluginR :: YesodAuth master => Text -> [Text] -> GHandler Auth master ()
+handlePluginR :: Text -> [Text] -> AuthHandler master TypedContent
handlePluginR plugin pieces = do
master <- getYesod
env <- waiRequest
@@ -248,49 +483,122 @@
[] -> notFound
ap:_ -> apDispatch ap method pieces
-maybeAuth :: ( YesodAuth master
-#if MIN_VERSION_persistent(1, 1, 0)
- , PersistMonadBackend (b (GHandler sub master)) ~ PersistEntityBackend val
- , b ~ YesodPersistBackend master
+-- | Similar to 'maybeAuthId', but additionally look up the value associated
+-- 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
+maybeAuth :: ( YesodAuthPersist master
+ , val ~ AuthEntity master
, Key val ~ AuthId master
- , PersistStore (b (GHandler sub master))
-#else
- , b ~ YesodPersistBackend master
- , b ~ PersistEntityBackend val
- , Key b val ~ AuthId master
- , PersistStore b (GHandler sub master)
-#endif
, PersistEntity val
- , YesodPersist master
- ) => GHandler sub master (Maybe (Entity val))
-maybeAuth = runMaybeT $ do
- aid <- MaybeT $ maybeAuthId
- a <- MaybeT $ runDB $ get aid
- return $ Entity aid a
+ , Typeable val
+ , MonadHandler m
+ , HandlerSite m ~ master
+ ) => m (Maybe (Entity val))
+maybeAuth = fmap (fmap (uncurry Entity)) maybeAuthPair
-requireAuthId :: YesodAuth master => GHandler sub master (AuthId master)
-requireAuthId = maybeAuthId >>= maybe redirectLogin return
+-- | Similar to 'maybeAuth', but doesn’t assume that you are using a
+-- Persistent database.
+--
+-- @since 1.4.0
+maybeAuthPair
+ :: ( YesodAuthPersist master
+ , Typeable (AuthEntity master)
+ , MonadHandler m
+ , HandlerSite m ~ master
+ )
+ => m (Maybe (AuthId master, AuthEntity master))
+maybeAuthPair = runMaybeT $ do
+ aid <- MaybeT maybeAuthId
+ ae <- MaybeT $ cachedAuth aid
+ return (aid, ae)
-requireAuth :: ( YesodAuth master
- , b ~ YesodPersistBackend master
-#if MIN_VERSION_persistent(1, 1, 0)
- , PersistMonadBackend (b (GHandler sub master)) ~ PersistEntityBackend val
+
+newtype CachedMaybeAuth val = CachedMaybeAuth { unCachedMaybeAuth :: Maybe val }
+
+-- | Class which states that the given site is an instance of @YesodAuth@
+-- and that its @AuthId@ is a lookup key for the full user information in
+-- a @YesodPersist@ database.
+--
+-- The default implementation of @getAuthEntity@ assumes that the @AuthId@
+-- for the @YesodAuth@ superclass is in fact a persistent @Key@ for the
+-- 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
+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.:
+ --
+ -- > type AuthId MySite = UserId
+ -- > AuthEntity MySite ~ User
+ --
+ -- @since 1.2.0
+ type AuthEntity master :: Type
+ type AuthEntity master = KeyEntity (AuthId master)
+
+ getAuthEntity :: (MonadHandler m, HandlerSite m ~ master)
+ => AuthId master -> m (Maybe (AuthEntity master))
+
+ default getAuthEntity
+ :: ( YesodPersistBackend master ~ backend
+ , PersistRecordBackend (AuthEntity master) backend
+ , Key (AuthEntity master) ~ AuthId master
+ , PersistStore backend
+ , MonadHandler m
+ , HandlerSite m ~ master
+ )
+ => AuthId master -> m (Maybe (AuthEntity master))
+ getAuthEntity = liftHandler . runDB . get
+
+
+type family KeyEntity key
+type instance KeyEntity (Key x) = x
+
+-- | 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 :: (MonadHandler m, YesodAuth (HandlerSite m)) => m (AuthId (HandlerSite m))
+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
+requireAuth :: ( YesodAuthPersist master
+ , val ~ AuthEntity master
, Key val ~ AuthId master
- , PersistStore (b (GHandler sub master))
-#else
- , b ~ PersistEntityBackend val
- , Key b val ~ AuthId master
- , PersistStore b (GHandler sub master)
-#endif
, PersistEntity val
- , YesodPersist master
- ) => GHandler sub master (Entity val)
-requireAuth = maybeAuth >>= maybe redirectLogin return
+ , Typeable val
+ , MonadHandler m
+ , HandlerSite m ~ master
+ ) => m (Entity val)
+requireAuth = maybeAuth >>= maybe handleAuthLack return
-redirectLogin :: Yesod master => GHandler sub master a
+-- | 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)
+ , MonadHandler m
+ , HandlerSite m ~ master
+ )
+ => m (AuthId master, AuthEntity master)
+requireAuthPair = maybeAuthPair >>= maybe handleAuthLack return
+
+handleAuthLack :: (YesodAuth (HandlerSite m), MonadHandler m) => m a
+handleAuthLack = do
+ aj <- acceptsJson
+ if aj then notAuthenticated else redirectLogin
+
+redirectLogin :: (YesodAuth (HandlerSite m), MonadHandler m) => m a
redirectLogin = do
y <- getYesod
- setUltDestCurrent
+ when (redirectToCurrent y) setUltDestCurrent
case authRoute y of
Just z -> redirect z
Nothing -> permissionDenied "Please configure authRoute"
@@ -298,7 +606,12 @@
instance YesodAuth master => RenderMessage master AuthMessage where
renderMessage = renderAuthMessage
-data AuthException = InvalidBrowserIDAssertion
- | InvalidFacebookResponse
- deriving (Show, Typeable)
+data AuthException = InvalidFacebookResponse
+ deriving Show
instance Exception AuthException
+
+instance YesodAuth master => YesodSubDispatch Auth master where
+ yesodSubDispatch = $(mkYesodSubDispatch resourcesAuth)
+
+asHtml :: Html -> Html
+asHtml = id
diff --git a/Yesod/Auth/BrowserId.hs b/Yesod/Auth/BrowserId.hs
--- a/Yesod/Auth/BrowserId.hs
+++ b/Yesod/Auth/BrowserId.hs
@@ -1,66 +1,91 @@
-{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
+
+-- | NOTE: Mozilla Persona will be shut down by the end of 2016, therefore this
+-- module is no longer recommended for use.
module Yesod.Auth.BrowserId
+ {-# DEPRECATED "Mozilla Persona will be shut down by the end of 2016" #-}
( authBrowserId
- , authBrowserIdAudience
- , createOnClick
+ , createOnClick, createOnClickOverride
+ , def
+ , BrowserIdSettings
+ , bisAudience
+ , bisLazyLoad
+ , forwardUrl
) where
import Yesod.Auth
import Web.Authenticate.BrowserId
import Data.Text (Text)
import Yesod.Core
-import Text.Hamlet (hamlet)
import qualified Data.Text as T
import Data.Maybe (fromMaybe)
-import Control.Monad.IO.Class (liftIO)
-import Control.Monad (when)
-import Control.Exception (throwIO)
-import Text.Julius (julius, rawJS)
-import Data.Aeson (toJSON)
+import Control.Monad (when, unless)
+import Text.Julius (rawJS)
import Network.URI (uriPath, parseURI)
import Data.FileEmbed (embedFile)
import Data.ByteString (ByteString)
+import Data.Default
pid :: Text
pid = "browserid"
-complete :: Route Auth
-complete = PluginR pid []
+forwardUrl :: AuthRoute
+forwardUrl = PluginR pid []
--- | Log into browser ID with an audience value determined from the 'approot'.
-authBrowserId :: YesodAuth m => AuthPlugin m
-authBrowserId = helper Nothing
+complete :: AuthRoute
+complete = forwardUrl
--- | Log into browser ID with the given audience value. Note that this must be
--- your actual hostname, or login will fail.
-authBrowserIdAudience
- :: YesodAuth m
- => Text -- ^ audience
- -> AuthPlugin m
-authBrowserIdAudience = helper . Just
+-- | A settings type for various configuration options relevant to BrowserID.
+--
+-- See: