haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Start converting yesod-auth over

Browse Source
This commit is contained in:
Michael Snoyman 2017-12-13 13:44:59 +02:00
parent 47ee7384ea
commit 61c887f501
No known key found for this signature in database
GPG Key ID: A048E8C057E86876
5 changed files with 83 additions and 80 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

113
yesod-auth/Yesod/Auth.hs
View File

@ -64,7 +64,7 @@ import Network.HTTP.Client (Manager, Request, withResponse, Response, BodyReader
import qualified Network.Wai as W import qualified Network.Wai as W
import Yesod.Core import Yesod.Core
import Yesod.Core.Types (HandlerT(..), unHandlerT) import Yesod.Core.Types (HandlerFor(..))
import Yesod.Persist import Yesod.Persist
import Yesod.Auth.Message (AuthMessage, defaultMessage) import Yesod.Auth.Message (AuthMessage, defaultMessage)
import qualified Yesod.Auth.Message as Msg import qualified Yesod.Auth.Message as Msg
@ -72,13 +72,12 @@ import Yesod.Form (FormMessage)
import Data.Typeable (Typeable) import Data.Typeable (Typeable)
import Control.Exception (Exception) import Control.Exception (Exception)
import Network.HTTP.Types (Status, internalServerError500, unauthorized401) import Network.HTTP.Types (Status, internalServerError500, unauthorized401)
import Control.Monad.Trans.Resource (MonadResourceBase)
import qualified Control.Monad.Trans.Writer as Writer import qualified Control.Monad.Trans.Writer as Writer
import Control.Monad (void) import Control.Monad (void)
type AuthRoute = Route Auth type AuthRoute = Route Auth
type AuthHandler master a = YesodAuth master => HandlerT Auth (HandlerT master IO) a type AuthHandler master a = forall m. (MonadSubHandler m, YesodAuth master, master ~ HandlerSite m, Auth ~ SubHandlerSite m) => m a
type Method = Text type Method = Text
type Piece = Text type Piece = Text
@ -94,7 +93,7 @@ data AuthenticationResult master
data AuthPlugin master = AuthPlugin data AuthPlugin master = AuthPlugin
{ apName :: Text { apName :: Text
, apDispatch :: Method -> [Piece] -> AuthHandler master TypedContent , apDispatch :: Method -> [Piece] -> AuthHandler master TypedContent
, apLogin :: (Route Auth -> Route master) -> WidgetT master IO () , apLogin :: (Route Auth -> Route master) -> WidgetFor master ()
} }
getAuth :: a -> Auth getAuth :: a -> Auth
@ -111,7 +110,7 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
type AuthId master type AuthId master
-- | specify the layout. Uses defaultLayout by default -- | specify the layout. Uses defaultLayout by default
authLayout :: WidgetT master IO () -> HandlerT master IO Html authLayout :: WidgetFor master () -> HandlerFor master Html
authLayout = defaultLayout authLayout = defaultLayout
-- | Default destination on successful login, if no other -- | Default destination on successful login, if no other
@ -127,7 +126,7 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
-- Default implementation is in terms of @'getAuthId'@ -- Default implementation is in terms of @'getAuthId'@
-- --
-- Since: 1.4.4 -- Since: 1.4.4
authenticate :: Creds master -> HandlerT master IO (AuthenticationResult master) authenticate :: Creds master -> HandlerFor master (AuthenticationResult master)
authenticate creds = do authenticate creds = do
muid <- getAuthId creds muid <- getAuthId creds
@ -137,7 +136,7 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
-- --
-- Default implementation is in terms of @'authenticate'@ -- Default implementation is in terms of @'authenticate'@
-- --
getAuthId :: Creds master -> HandlerT master IO (Maybe (AuthId master)) getAuthId :: Creds master -> HandlerFor master (Maybe (AuthId master))
getAuthId creds = do getAuthId creds = do
auth <- authenticate creds auth <- authenticate creds
@ -167,7 +166,7 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
-- > lift $ redirect HomeR -- or any other Handler code you want -- > lift $ redirect HomeR -- or any other Handler code you want
-- > defaultLoginHandler -- > defaultLoginHandler
-- --
loginHandler :: HandlerT Auth (HandlerT master IO) Html loginHandler :: AuthHandler master Html
loginHandler = defaultLoginHandler loginHandler = defaultLoginHandler
-- | Used for i18n of messages provided by this package. -- | Used for i18n of messages provided by this package.
@ -196,11 +195,11 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
-- | Called on a successful login. By default, calls -- | Called on a successful login. By default, calls
-- @addMessageI "success" NowLoggedIn@. -- @addMessageI "success" NowLoggedIn@.
onLogin :: HandlerT master IO () onLogin :: HandlerFor master ()
onLogin = addMessageI "success" Msg.NowLoggedIn onLogin = addMessageI "success" Msg.NowLoggedIn
-- | Called on logout. By default, does nothing -- | Called on logout. By default, does nothing
onLogout :: HandlerT master IO () onLogout :: HandlerFor master ()
onLogout = return () onLogout = return ()
-- | Retrieves user credentials, if user is authenticated. -- | Retrieves user credentials, if user is authenticated.
@ -212,16 +211,16 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
-- other than a browser. -- other than a browser.
-- --
-- Since 1.2.0 -- Since 1.2.0
maybeAuthId :: HandlerT master IO (Maybe (AuthId master)) maybeAuthId :: HandlerFor master (Maybe (AuthId master))
default maybeAuthId default maybeAuthId
:: (YesodAuthPersist master, Typeable (AuthEntity master)) :: (YesodAuthPersist master, Typeable (AuthEntity master))
=> HandlerT master IO (Maybe (AuthId master)) => HandlerFor master (Maybe (AuthId master))
maybeAuthId = defaultMaybeAuthId maybeAuthId = defaultMaybeAuthId
-- | Called on login error for HTTP requests. By default, calls -- | Called on login error for HTTP requests. By default, calls
-- @addMessage@ with "error" as status and redirects to @dest@. -- @addMessage@ with "error" as status and redirects to @dest@.
onErrorHtml :: (MonadResourceBase m) => Route master -> Text -> HandlerT master m Html onErrorHtml :: Route master -> Text -> HandlerFor master Html
onErrorHtml dest msg = do onErrorHtml dest msg = do
addMessage "error" $ toHtml msg addMessage "error" $ toHtml msg
fmap asHtml $ redirect dest fmap asHtml $ redirect dest
@ -231,10 +230,10 @@ 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. -- 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 -- 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 :: Request -> (Response BodyReader -> HandlerFor master a) -> HandlerFor master a
runHttpRequest req inner = do runHttpRequest req inner = do
man <- authHttpManager Control.Applicative.<$> getYesod man <- authHttpManager Control.Applicative.<$> getYesod
HandlerT $ \t -> withResponse req man $ \res -> unHandlerT (inner res) t HandlerFor $ \t -> withResponse req man $ \res -> unHandlerFor (inner res) t
{-# MINIMAL loginDest, logoutDest, (authenticate | getAuthId), authPlugins, authHttpManager #-} {-# MINIMAL loginDest, logoutDest, (authenticate | getAuthId), authPlugins, authHttpManager #-}
@ -255,7 +254,7 @@ credsKey = "_ID"
-- Since 1.1.2 -- Since 1.1.2
defaultMaybeAuthId defaultMaybeAuthId
:: (YesodAuthPersist master, Typeable (AuthEntity master)) :: (YesodAuthPersist master, Typeable (AuthEntity master))
=> HandlerT master IO (Maybe (AuthId master)) => HandlerFor master (Maybe (AuthId master))
defaultMaybeAuthId = runMaybeT $ do defaultMaybeAuthId = runMaybeT $ do
s <- MaybeT $ lookupSession credsKey s <- MaybeT $ lookupSession credsKey
aid <- MaybeT $ return $ fromPathPiece s aid <- MaybeT $ return $ fromPathPiece s
@ -264,7 +263,7 @@ defaultMaybeAuthId = runMaybeT $ do
cachedAuth cachedAuth
:: (YesodAuthPersist master, Typeable (AuthEntity master)) :: (YesodAuthPersist master, Typeable (AuthEntity master))
=> AuthId master -> HandlerT master IO (Maybe (AuthEntity master)) => AuthId master -> HandlerFor master (Maybe (AuthEntity master))
cachedAuth cachedAuth
= fmap unCachedMaybeAuth = fmap unCachedMaybeAuth
. cached . cached
@ -281,48 +280,47 @@ cachedAuth
defaultLoginHandler :: AuthHandler master Html defaultLoginHandler :: AuthHandler master Html
defaultLoginHandler = do defaultLoginHandler = do
tp <- getRouteToParent tp <- getRouteToParent
lift $ authLayout $ do liftHandler $ authLayout $ do
setTitleI Msg.LoginTitle setTitleI Msg.LoginTitle
master <- getYesod master <- getYesod
mapM_ (flip apLogin tp) (authPlugins master) mapM_ (flip apLogin tp) (authPlugins master)
loginErrorMessageI :: (MonadResourceBase m, YesodAuth master) loginErrorMessageI :: (YesodAuth (HandlerSite m), MonadSubHandler m)
=> Route child => Route (SubHandlerSite m)
-> AuthMessage -> AuthMessage
-> HandlerT child (HandlerT master m) TypedContent -> m TypedContent
loginErrorMessageI dest msg = do loginErrorMessageI dest msg = do
toParent <- getRouteToParent toParent <- getRouteToParent
lift $ loginErrorMessageMasterI (toParent dest) msg liftHandler $ loginErrorMessageMasterI (toParent dest) msg
loginErrorMessageMasterI :: (YesodAuth master, MonadResourceBase m, RenderMessage master AuthMessage) loginErrorMessageMasterI :: (YesodAuth master, RenderMessage master AuthMessage)
=> Route master => Route master
-> AuthMessage -> AuthMessage
-> HandlerT master m TypedContent -> HandlerFor master TypedContent
loginErrorMessageMasterI dest msg = do loginErrorMessageMasterI dest msg = do
mr <- getMessageRender mr <- getMessageRender
loginErrorMessage dest (mr msg) loginErrorMessage dest (mr msg)
-- | For HTML, set the message and redirect to the route. -- | For HTML, set the message and redirect to the route.
-- For JSON, send the message and a 401 status -- For JSON, send the message and a 401 status
loginErrorMessage :: (YesodAuth master, MonadResourceBase m) loginErrorMessage :: YesodAuth master
=> Route master => Route master
-> Text -> Text
-> HandlerT master m TypedContent -> HandlerFor master TypedContent
loginErrorMessage dest msg = messageJson401 msg (onErrorHtml dest msg) loginErrorMessage dest msg = messageJson401 msg (onErrorHtml dest msg)
messageJson401 :: MonadResourceBase m => Text -> HandlerT master m Html -> HandlerT master m TypedContent messageJson401 :: Text -> HandlerFor master Html -> HandlerFor master TypedContent
messageJson401 = messageJsonStatus unauthorized401 messageJson401 = messageJsonStatus unauthorized401
messageJson500 :: MonadResourceBase m => Text -> HandlerT master m Html -> HandlerT master m TypedContent messageJson500 :: Text -> HandlerFor master Html -> HandlerFor master TypedContent
messageJson500 = messageJsonStatus internalServerError500 messageJson500 = messageJsonStatus internalServerError500
messageJsonStatus :: MonadResourceBase m messageJsonStatus :: Status
=> Status
-> Text -> Text
-> HandlerT master m Html -> HandlerFor master Html
-> HandlerT master m TypedContent -> HandlerFor master TypedContent
messageJsonStatus status msg html = selectRep $ do messageJsonStatus status msg html = selectRep $ do
provideRep html provideRep html
provideRep $ do provideRep $ do
@ -336,7 +334,7 @@ provideJsonMessage msg = provideRep $ return $ object ["message" .= msg]
setCredsRedirect :: YesodAuth master setCredsRedirect :: YesodAuth master
=> Creds master -- ^ new credentials => Creds master -- ^ new credentials
-> HandlerT master IO TypedContent -> HandlerFor master TypedContent
setCredsRedirect creds = do setCredsRedirect creds = do
y <- getYesod y <- getYesod
auth <- authenticate creds auth <- authenticate creds
@ -378,7 +376,7 @@ setCredsRedirect creds = do
setCreds :: YesodAuth master setCreds :: YesodAuth master
=> Bool -- ^ if HTTP redirects should be done => Bool -- ^ if HTTP redirects should be done
-> Creds master -- ^ new credentials -> Creds master -- ^ new credentials
-> HandlerT master IO () -> HandlerFor master ()
setCreds doRedirects creds = setCreds doRedirects creds =
if doRedirects if doRedirects
then void $ setCredsRedirect creds then void $ setCredsRedirect creds
@ -389,9 +387,9 @@ setCreds doRedirects creds =
-- | same as defaultLayoutJson, but uses authLayout -- | same as defaultLayoutJson, but uses authLayout
authLayoutJson :: (YesodAuth site, ToJSON j) authLayoutJson :: (YesodAuth site, ToJSON j)
=> WidgetT site IO () -- ^ HTML => WidgetFor site () -- ^ HTML
-> HandlerT site IO j -- ^ JSON -> HandlerFor site j -- ^ JSON
-> HandlerT site IO TypedContent -> HandlerFor site TypedContent
authLayoutJson w json = selectRep $ do authLayoutJson w json = selectRep $ do
provideRep $ authLayout w provideRep $ authLayout w
provideRep $ fmap toJSON json provideRep $ fmap toJSON json
@ -399,18 +397,18 @@ authLayoutJson w json = selectRep $ do
-- | Clears current user credentials for the session. -- | Clears current user credentials for the session.
-- --
-- Since 1.1.7 -- Since 1.1.7
clearCreds :: YesodAuth master clearCreds :: (MonadHandler m, YesodAuth (HandlerSite m))
=> Bool -- ^ if HTTP redirect to 'logoutDest' should be done => Bool -- ^ if HTTP redirect to 'logoutDest' should be done
-> HandlerT master IO () -> m ()
clearCreds doRedirects = do clearCreds doRedirects = do
y <- getYesod y <- getYesod
onLogout liftHandler onLogout
deleteSession credsKey deleteSession credsKey
when doRedirects $ do when doRedirects $ do
redirectUltDest $ logoutDest y redirectUltDest $ logoutDest y
getCheckR :: AuthHandler master TypedContent getCheckR :: AuthHandler master TypedContent
getCheckR = lift $ do getCheckR = liftHandler $ do
creds <- maybeAuthId creds <- maybeAuthId
authLayoutJson (do authLayoutJson (do
setTitle "Authentication Status" setTitle "Authentication Status"
@ -431,7 +429,7 @@ $nothing
] ]
setUltDestReferer' :: AuthHandler master () setUltDestReferer' :: AuthHandler master ()
setUltDestReferer' = lift $ do setUltDestReferer' = liftHandler $ do
master <- getYesod master <- getYesod
when (redirectToReferer master) setUltDestReferer when (redirectToReferer master) setUltDestReferer
@ -439,14 +437,16 @@ getLoginR :: AuthHandler master Html
getLoginR = setUltDestReferer' >> loginHandler getLoginR = setUltDestReferer' >> loginHandler
getLogoutR :: AuthHandler master () getLogoutR :: AuthHandler master ()
getLogoutR = setUltDestReferer' >> redirectToPost LogoutR getLogoutR = do
tp <- getRouteToParent
setUltDestReferer' >> redirectToPost (tp LogoutR)
postLogoutR :: AuthHandler master () postLogoutR :: AuthHandler master ()
postLogoutR = lift $ clearCreds True postLogoutR = clearCreds True
handlePluginR :: Text -> [Text] -> AuthHandler master TypedContent handlePluginR :: Text -> [Text] -> AuthHandler master TypedContent
handlePluginR plugin pieces = do handlePluginR plugin pieces = do
master <- lift getYesod master <- getYesod
env <- waiRequest env <- waiRequest
let method = decodeUtf8With lenientDecode $ W.requestMethod env let method = decodeUtf8With lenientDecode $ W.requestMethod env
case filter (\x -> apName x == plugin) (authPlugins master) of case filter (\x -> apName x == plugin) (authPlugins master) of
@ -463,7 +463,7 @@ maybeAuth :: ( YesodAuthPersist master
, Key val ~ AuthId master , Key val ~ AuthId master
, PersistEntity val , PersistEntity val
, Typeable val , Typeable val
) => HandlerT master IO (Maybe (Entity val)) ) => HandlerFor master (Maybe (Entity val))
maybeAuth = runMaybeT $ do maybeAuth = runMaybeT $ do
(aid, ae) <- MaybeT maybeAuthPair (aid, ae) <- MaybeT maybeAuthPair
return $ Entity aid ae return $ Entity aid ae
@ -473,7 +473,7 @@ maybeAuth = runMaybeT $ do
-- --
-- Since 1.4.0 -- Since 1.4.0
maybeAuthPair :: (YesodAuthPersist master, Typeable (AuthEntity master)) maybeAuthPair :: (YesodAuthPersist master, Typeable (AuthEntity master))
=> HandlerT master IO (Maybe (AuthId master, AuthEntity master)) => HandlerFor master (Maybe (AuthId master, AuthEntity master))
maybeAuthPair = runMaybeT $ do maybeAuthPair = runMaybeT $ do
aid <- MaybeT maybeAuthId aid <- MaybeT maybeAuthId
ae <- MaybeT $ cachedAuth aid ae <- MaybeT $ cachedAuth aid
@ -504,7 +504,7 @@ class (YesodAuth master, YesodPersist master) => YesodAuthPersist master where
type AuthEntity master :: * type AuthEntity master :: *
type AuthEntity master = KeyEntity (AuthId master) type AuthEntity master = KeyEntity (AuthId master)
getAuthEntity :: AuthId master -> HandlerT master IO (Maybe (AuthEntity master)) getAuthEntity :: AuthId master -> HandlerFor master (Maybe (AuthEntity master))
#if MIN_VERSION_persistent(2,5,0) #if MIN_VERSION_persistent(2,5,0)
default getAuthEntity default getAuthEntity
@ -513,7 +513,7 @@ class (YesodAuth master, YesodPersist master) => YesodAuthPersist master where
, Key (AuthEntity master) ~ AuthId master , Key (AuthEntity master) ~ AuthId master
, PersistStore backend , PersistStore backend
) )
=> AuthId master -> HandlerT master IO (Maybe (AuthEntity master)) => AuthId master -> HandlerFor master (Maybe (AuthEntity master))
#else #else
default getAuthEntity default getAuthEntity
:: ( YesodPersistBackend master :: ( YesodPersistBackend master
@ -522,7 +522,7 @@ class (YesodAuth master, YesodPersist master) => YesodAuthPersist master where
, PersistStore (YesodPersistBackend master) , PersistStore (YesodPersistBackend master)
, PersistEntity (AuthEntity master) , PersistEntity (AuthEntity master)
) )
=> AuthId master -> HandlerT master IO (Maybe (AuthEntity master)) => AuthId master -> HandlerFor master (Maybe (AuthEntity master))
#endif #endif
getAuthEntity = runDB . get getAuthEntity = runDB . get
@ -534,7 +534,7 @@ type instance KeyEntity (Key x) = x
-- authenticated or responds with error 401 if this is an API client (expecting JSON). -- authenticated or responds with error 401 if this is an API client (expecting JSON).
-- --
-- Since 1.1.0 -- Since 1.1.0
requireAuthId :: YesodAuth master => HandlerT master IO (AuthId master) requireAuthId :: YesodAuth master => HandlerFor master (AuthId master)
requireAuthId = maybeAuthId >>= maybe handleAuthLack return requireAuthId = maybeAuthId >>= maybe handleAuthLack return
-- | Similar to 'maybeAuth', but redirects to a login page if user is not -- | Similar to 'maybeAuth', but redirects to a login page if user is not
@ -546,7 +546,7 @@ requireAuth :: ( YesodAuthPersist master
, Key val ~ AuthId master , Key val ~ AuthId master
, PersistEntity val , PersistEntity val
, Typeable val , Typeable val
) => HandlerT master IO (Entity val) ) => HandlerFor master (Entity val)
requireAuth = maybeAuth >>= maybe handleAuthLack return requireAuth = maybeAuth >>= maybe handleAuthLack return
-- | Similar to 'requireAuth', but not tied to Persistent's 'Entity' type. -- | Similar to 'requireAuth', but not tied to Persistent's 'Entity' type.
@ -554,15 +554,15 @@ requireAuth = maybeAuth >>= maybe handleAuthLack return
-- --
-- Since 1.4.0 -- Since 1.4.0
requireAuthPair :: (YesodAuthPersist master, Typeable (AuthEntity master)) requireAuthPair :: (YesodAuthPersist master, Typeable (AuthEntity master))
=> HandlerT master IO (AuthId master, AuthEntity master) => HandlerFor master (AuthId master, AuthEntity master)
requireAuthPair = maybeAuthPair >>= maybe handleAuthLack return requireAuthPair = maybeAuthPair >>= maybe handleAuthLack return
handleAuthLack :: YesodAuth master => HandlerT master IO a handleAuthLack :: YesodAuth master => HandlerFor master a
handleAuthLack = do handleAuthLack = do
aj <- acceptsJson aj <- acceptsJson
if aj then notAuthenticated else redirectLogin if aj then notAuthenticated else redirectLogin
redirectLogin :: YesodAuth master => HandlerT master IO a redirectLogin :: YesodAuth master => HandlerFor master a
redirectLogin = do redirectLogin = do
y <- getYesod y <- getYesod
when (redirectToCurrent y) setUltDestCurrent when (redirectToCurrent y) setUltDestCurrent
@ -577,7 +577,8 @@ data AuthException = InvalidFacebookResponse
deriving (Show, Typeable) deriving (Show, Typeable)
instance Exception AuthException instance Exception AuthException
instance YesodAuth master => YesodSubDispatch Auth (HandlerT master IO) where -- FIXME this is ugly, and I probably want to ditch the MonadSubHandler typeclass anyway
instance (YesodAuth (HandlerSite m), MonadSubHandler m) => YesodSubDispatch Auth m where
yesodSubDispatch = $(mkYesodSubDispatch resourcesAuth) yesodSubDispatch = $(mkYesodSubDispatch resourcesAuth)
asHtml :: Html -> Html asHtml :: Html -> Html

11
yesod-auth/Yesod/Auth/BrowserId.hs
View File

@ -70,20 +70,21 @@ authBrowserId bis@BrowserIdSettings {..} = AuthPlugin
, apDispatch = \m ps -> , apDispatch = \m ps ->
case (m, ps) of case (m, ps) of
("GET", [assertion]) -> do ("GET", [assertion]) -> do
master <- lift getYesod master <- getYesod
audience <- audience <-
case bisAudience of case bisAudience of
Just a -> return a Just a -> return a
Nothing -> do Nothing -> do
r <- getUrlRender r <- getUrlRender
return $ T.takeWhile (/= '/') $ stripScheme $ r LoginR tm <- getRouteToParent
memail <- lift $ checkAssertion audience assertion (authHttpManager master) return $ T.takeWhile (/= '/') $ stripScheme $ r $ tm LoginR
memail <- liftHandler $ checkAssertion audience assertion (authHttpManager master)
case memail of case memail of
Nothing -> do Nothing -> do
$logErrorS "yesod-auth" "BrowserID assertion failure" $logErrorS "yesod-auth" "BrowserID assertion failure"
tm <- getRouteToParent tm <- getRouteToParent
lift $ loginErrorMessage (tm LoginR) "BrowserID login error." liftHandler $ loginErrorMessage (tm LoginR) "BrowserID login error."
Just email -> lift $ setCredsRedirect Creds Just email -> liftHandler $ setCredsRedirect Creds
{ credsPlugin = pid { credsPlugin = pid
, credsIdent = email , credsIdent = email
, credsExtra = [] , credsExtra = []

32
yesod-core/Yesod/Core/Class/Dispatch.hs
View File

@ -36,10 +36,8 @@ instance MonadHandler m => YesodSubDispatch WaiSubsiteWithAuth m where
WaiSubsiteWithAuth set = ysreGetSub $ yreSite $ ysreParentEnv WaiSubsiteWithAuth set = ysreGetSub $ yreSite $ ysreParentEnv
handlert = sendWaiApplication set handlert = sendWaiApplication set
type SubHandler child parent a = ReaderT (SubsiteData child parent) (HandlerFor parent) a
data SubsiteData child parent = SubsiteData data SubsiteData child parent = SubsiteData
{ sdToParentRoute :: !(Route child -> Route parent) { sdRouteToParent :: !(Route child -> Route parent)
, sdCurrentRoute :: !(Maybe (Route child)) , sdCurrentRoute :: !(Maybe (Route child))
, sdSubsiteData :: !child , sdSubsiteData :: !child
} }
@ -48,21 +46,21 @@ class MonadHandler m => MonadSubHandler m where
type SubHandlerSite m type SubHandlerSite m
getSubYesod :: m (SubHandlerSite m) getSubYesod :: m (SubHandlerSite m)
getToParentRoute :: m (Route (SubHandlerSite m) -> Route (HandlerSite m)) getRouteToParent :: m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getSubCurrentRoute :: m (Maybe (Route (SubHandlerSite m))) getSubCurrentRoute :: m (Maybe (Route (SubHandlerSite m)))
instance MonadSubHandler (HandlerFor site) where instance MonadSubHandler (HandlerFor site) where
type SubHandlerSite (HandlerFor site) = site type SubHandlerSite (HandlerFor site) = site
getSubYesod = getYesod getSubYesod = getYesod
getToParentRoute = return id getRouteToParent = return id
getSubCurrentRoute = getCurrentRoute getSubCurrentRoute = getCurrentRoute
instance MonadSubHandler (WidgetFor site) where instance MonadSubHandler (WidgetFor site) where
type SubHandlerSite (WidgetFor site) = site type SubHandlerSite (WidgetFor site) = site
getSubYesod = getYesod getSubYesod = getYesod
getToParentRoute = return id getRouteToParent = return id
getSubCurrentRoute = getCurrentRoute getSubCurrentRoute = getCurrentRoute
instance (MonadSubHandler m, parent ~ SubHandlerSite m) => MonadSubHandler (ReaderT (SubsiteData child parent) m) where instance (MonadSubHandler m, parent ~ SubHandlerSite m) => MonadSubHandler (ReaderT (SubsiteData child parent) m) where
@ -70,21 +68,23 @@ instance (MonadSubHandler m, parent ~ SubHandlerSite m) => MonadSubHandler (Read
getSubYesod = fmap sdSubsiteData ask getSubYesod = fmap sdSubsiteData ask
getSubCurrentRoute = fmap sdCurrentRoute ask getSubCurrentRoute = fmap sdCurrentRoute ask
getToParentRoute = ReaderT $ \sd -> do getRouteToParent = ReaderT $ \sd -> do
toParent' <- getToParentRoute toParent' <- getRouteToParent
return $ toParent' . sdToParentRoute sd return $ toParent' . sdRouteToParent sd
subHelper subHelper
:: (ToTypedContent content, MonadSubHandler m, parent ~ HandlerSite m) :: (ToTypedContent content, MonadSubHandler m, master ~ HandlerSite m, parent ~ SubHandlerSite m)
=> ReaderT (SubsiteData child parent) m content => ReaderT (SubsiteData child master) m content
-> YesodSubRunnerEnv child parent m -> YesodSubRunnerEnv child parent m
-> Maybe (Route child) -> Maybe (Route child)
-> W.Application -> W.Application
subHelper (ReaderT f) YesodSubRunnerEnv {..} mroute = subHelper (ReaderT f) YesodSubRunnerEnv {..} mroute =
ysreParentRunner handler ysreParentEnv (fmap ysreToParentRoute mroute) ysreParentRunner handler ysreParentEnv (fmap ysreToParentRoute mroute)
where where
handler = fmap toTypedContent $ f SubsiteData handler = fmap toTypedContent $ do
{ sdToParentRoute = ysreToParentRoute tm <- getRouteToParent
, sdCurrentRoute = mroute f SubsiteData
, sdSubsiteData = ysreGetSub $ yreSite ysreParentEnv { sdRouteToParent = tm . ysreToParentRoute
} , sdCurrentRoute = mroute
, sdSubsiteData = ysreGetSub $ yreSite ysreParentEnv
}

3
yesod-core/Yesod/Core/Class/Handler.hs
View File

@ -14,6 +14,7 @@ module Yesod.Core.Class.Handler
) where ) where
import Yesod.Core.Types import Yesod.Core.Types
import Control.Monad.Logger (MonadLogger)
import Control.Monad.Trans.Resource (MonadResource) import Control.Monad.Trans.Resource (MonadResource)
import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Class (lift)
#if __GLASGOW_HASKELL__ < 710 #if __GLASGOW_HASKELL__ < 710
@ -35,7 +36,7 @@ import qualified Control.Monad.Trans.State.Strict as Strict ( StateT )
import qualified Control.Monad.Trans.Writer.Strict as Strict ( WriterT ) import qualified Control.Monad.Trans.Writer.Strict as Strict ( WriterT )
-- FIXME should we just use MonadReader instances instead? -- FIXME should we just use MonadReader instances instead?
class MonadResource m => MonadHandler m where class (MonadResource m, MonadLogger m) => MonadHandler m where
type HandlerSite m type HandlerSite m
liftHandler :: HandlerFor (HandlerSite m) a -> m a liftHandler :: HandlerFor (HandlerSite m) a -> m a

4
yesod-core/test/YesodCoreTest/NoOverloadedStrings.hs
View File

@ -29,10 +29,10 @@ getBazR = liftHandler $ defaultLayout [whamlet|Used Default Layout|]
getBinR :: (MonadSubHandler m, Yesod (HandlerSite m), SubHandlerSite m ~ Subsite) => m Html getBinR :: (MonadSubHandler m, Yesod (HandlerSite m), SubHandlerSite m ~ Subsite) => m Html
getBinR = do getBinR = do
toParentRoute <- getToParentRoute routeToParent <- getRouteToParent
liftHandler $ defaultLayout [whamlet| liftHandler $ defaultLayout [whamlet|
<p>Used defaultLayoutT <p>Used defaultLayoutT
<a href=@{toParentRoute BazR}>Baz <a href=@{routeToParent BazR}>Baz
|] |]
getOnePiecesR :: Monad m => Int -> m () getOnePiecesR :: Monad m => Int -> m ()