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

Be gone with ye HandlerT!

Browse Source
This commit is contained in:
Michael Snoyman 2017-12-13 09:53:14 +02:00
parent 1c2914eded
commit 47ee7384ea
No known key found for this signature in database
GPG Key ID: A048E8C057E86876
17 changed files with 290 additions and 319 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
yesod-core/ChangeLog.md
View File

@ -1,3 +1,7 @@
## 1.5.0
* Overhaul of `HandlerT`/`WidgetT` to no longer be transformers.
## 1.4.38 ## 1.4.38
* Internal only change, users of stable API are unaffected: `WidgetT` * Internal only change, users of stable API are unaffected: `WidgetT`

14
yesod-core/Yesod/Core.hs
View File

@ -67,15 +67,15 @@ module Yesod.Core
-- * JS loaders -- * JS loaders
, ScriptLoadPosition (..) , ScriptLoadPosition (..)
, BottomOfHeadAsync , BottomOfHeadAsync
-- * Subsites -- * Generalizing type classes
, MonadHandler (..) , MonadHandler (..)
, MonadWidget (..) , MonadWidget (..)
, getRouteToParent
, defaultLayoutSub
-- * Approot -- * Approot
, guessApproot , guessApproot
, guessApprootOr , guessApprootOr
, getApprootText , getApprootText
-- * Subsites
, MonadSubHandler (..)
-- * Misc -- * Misc
, yesodVersion , yesodVersion
, yesodRender , yesodRender
@ -185,14 +185,6 @@ maybeAuthorized r isWrite = do
x <- isAuthorized r isWrite x <- isAuthorized r isWrite
return $ if x == Authorized then Just r else Nothing return $ if x == Authorized then Just r else Nothing
getRouteToParent :: Monad m => HandlerT child (HandlerT parent m) (Route child -> Route parent)
getRouteToParent = HandlerT $ return . handlerToParent
defaultLayoutSub :: Yesod parent
=> WidgetT child IO ()
-> HandlerT child (HandlerT parent IO) Html
defaultLayoutSub cwidget = widgetToParentWidget cwidget >>= lift . defaultLayout
showIntegral :: Integral a => a -> String showIntegral :: Integral a => a -> String
showIntegral x = show (fromIntegral x :: Integer) showIntegral x = show (fromIntegral x :: Integer)

4
yesod-core/Yesod/Core/Class/Breadcrumbs.hs
View File

@ -11,11 +11,11 @@ import Data.Text (Text)
class YesodBreadcrumbs site where class YesodBreadcrumbs site where
-- | Returns the title and the parent resource, if available. If you return -- | Returns the title and the parent resource, if available. If you return
-- a 'Nothing', then this is considered a top-level page. -- a 'Nothing', then this is considered a top-level page.
breadcrumb :: Route site -> HandlerT site IO (Text , Maybe (Route site)) breadcrumb :: Route site -> HandlerFor site (Text , Maybe (Route site))
-- | Gets the title of the current page and the hierarchy of parent pages, -- | Gets the title of the current page and the hierarchy of parent pages,
-- along with their respective titles. -- along with their respective titles.
breadcrumbs :: YesodBreadcrumbs site => HandlerT site IO (Text, [(Route site, Text)]) breadcrumbs :: YesodBreadcrumbs site => HandlerFor site (Text, [(Route site, Text)])
breadcrumbs = do breadcrumbs = do
x <- getCurrentRoute x <- getCurrentRoute
case x of case x of

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

@ -6,13 +6,13 @@
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
module Yesod.Core.Class.Dispatch where module Yesod.Core.Class.Dispatch where
import Yesod.Routes.Class
import qualified Network.Wai as W import qualified Network.Wai as W
import Yesod.Core.Types import Yesod.Core.Types
import Yesod.Core.Content import Yesod.Core.Content (ToTypedContent (..))
import Yesod.Core.Handler (sendWaiApplication, stripHandlerT) import Yesod.Core.Handler (sendWaiApplication, getYesod, getCurrentRoute)
import Yesod.Core.Class.Yesod
import Yesod.Core.Class.Handler import Yesod.Core.Class.Handler
import Yesod.Core.Class.Yesod
import Control.Monad.Trans.Reader (ReaderT (..), ask)
-- | This class is automatically instantiated when you use the template haskell -- | This class is automatically instantiated when you use the template haskell
-- mkYesod function. You should never need to deal with it directly. -- mkYesod function. You should never need to deal with it directly.
@ -28,24 +28,63 @@ instance YesodSubDispatch WaiSubsite master where
where where
WaiSubsite app = ysreGetSub $ yreSite ysreParentEnv WaiSubsite app = ysreGetSub $ yreSite ysreParentEnv
instance YesodSubDispatch WaiSubsiteWithAuth (HandlerT master IO) where instance MonadHandler m => YesodSubDispatch WaiSubsiteWithAuth m where
yesodSubDispatch YesodSubRunnerEnv {..} req = yesodSubDispatch YesodSubRunnerEnv {..} req =
ysreParentRunner base ysreParentEnv (fmap ysreToParentRoute route) req ysreParentRunner handlert ysreParentEnv (fmap ysreToParentRoute route) req
where where
base = stripHandlerT handlert ysreGetSub ysreToParentRoute route
route = Just $ WaiSubsiteWithAuthRoute (W.pathInfo req) [] route = Just $ WaiSubsiteWithAuthRoute (W.pathInfo req) []
WaiSubsiteWithAuth set = ysreGetSub $ yreSite $ ysreParentEnv WaiSubsiteWithAuth set = ysreGetSub $ yreSite $ ysreParentEnv
handlert = sendWaiApplication $ set handlert = sendWaiApplication set
-- | A helper function for creating YesodSubDispatch instances, used by the type SubHandler child parent a = ReaderT (SubsiteData child parent) (HandlerFor parent) a
-- internal generated code. This function has been exported since 1.4.11.
-- It promotes a subsite handler to a wai application. data SubsiteData child parent = SubsiteData
subHelper :: Monad m -- NOTE: This is incredibly similar in type signature to yesodRunner, should probably be pointed out/explained. { sdToParentRoute :: !(Route child -> Route parent)
=> HandlerT child (HandlerT parent m) TypedContent , sdCurrentRoute :: !(Maybe (Route child))
-> YesodSubRunnerEnv child parent (HandlerT parent m) , sdSubsiteData :: !child
-> Maybe (Route child) }
-> W.Application
subHelper handlert YesodSubRunnerEnv {..} route = class MonadHandler m => MonadSubHandler m where
ysreParentRunner base ysreParentEnv (fmap ysreToParentRoute route) type SubHandlerSite m
getSubYesod :: m (SubHandlerSite m)
getToParentRoute :: m (Route (SubHandlerSite m) -> Route (HandlerSite m))
getSubCurrentRoute :: m (Maybe (Route (SubHandlerSite m)))
instance MonadSubHandler (HandlerFor site) where
type SubHandlerSite (HandlerFor site) = site
getSubYesod = getYesod
getToParentRoute = return id
getSubCurrentRoute = getCurrentRoute
instance MonadSubHandler (WidgetFor site) where
type SubHandlerSite (WidgetFor site) = site
getSubYesod = getYesod
getToParentRoute = return id
getSubCurrentRoute = getCurrentRoute
instance (MonadSubHandler m, parent ~ SubHandlerSite m) => MonadSubHandler (ReaderT (SubsiteData child parent) m) where
type SubHandlerSite (ReaderT (SubsiteData child parent) m) = child
getSubYesod = fmap sdSubsiteData ask
getSubCurrentRoute = fmap sdCurrentRoute ask
getToParentRoute = ReaderT $ \sd -> do
toParent' <- getToParentRoute
return $ toParent' . sdToParentRoute sd
subHelper
:: (ToTypedContent content, MonadSubHandler m, parent ~ HandlerSite m)
=> ReaderT (SubsiteData child parent) m content
-> YesodSubRunnerEnv child parent m
-> Maybe (Route child)
-> W.Application
subHelper (ReaderT f) YesodSubRunnerEnv {..} mroute =
ysreParentRunner handler ysreParentEnv (fmap ysreToParentRoute mroute)
where where
base = stripHandlerT (fmap toTypedContent handlert) ysreGetSub ysreToParentRoute route handler = fmap toTypedContent $ f SubsiteData
{ sdToParentRoute = ysreToParentRoute
, sdCurrentRoute = mroute
, sdSubsiteData = ysreGetSub $ yreSite ysreParentEnv
}

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

@ -9,11 +9,12 @@
module Yesod.Core.Class.Handler module Yesod.Core.Class.Handler
( MonadHandler (..) ( MonadHandler (..)
, MonadWidget (..) , MonadWidget (..)
, liftHandlerT
, liftWidgetT
) where ) where
import Yesod.Core.Types import Yesod.Core.Types
import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Resource (MonadResource)
import Control.Monad.Trans.Resource (MonadResource, MonadResourceBase)
import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Class (lift)
#if __GLASGOW_HASKELL__ < 710 #if __GLASGOW_HASKELL__ < 710
import Data.Monoid (Monoid) import Data.Monoid (Monoid)
@ -33,25 +34,27 @@ import qualified Control.Monad.Trans.RWS.Strict as Strict ( RWST )
import qualified Control.Monad.Trans.State.Strict as Strict ( StateT ) 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?
class MonadResource m => MonadHandler m where class MonadResource m => MonadHandler m where
type HandlerSite m type HandlerSite m
liftHandlerT :: HandlerT (HandlerSite m) IO a -> m a liftHandler :: HandlerFor (HandlerSite m) a -> m a
replaceToParent :: HandlerData site route -> HandlerData site () liftHandlerT :: MonadHandler m => HandlerFor (HandlerSite m) a -> m a
replaceToParent hd = hd { handlerToParent = const () } liftHandlerT = liftHandler
{-# DEPRECATED liftHandlerT "Use liftHandler instead" #-}
instance MonadResourceBase m => MonadHandler (HandlerT site m) where instance MonadHandler (HandlerFor site) where
type HandlerSite (HandlerT site m) = site type HandlerSite (HandlerFor site) = site
liftHandlerT (HandlerT f) = HandlerT $ liftIO . f . replaceToParent liftHandler = id
{-# RULES "liftHandlerT (HandlerT site IO)" liftHandlerT = id #-} {-# INLINE liftHandler #-}
instance MonadResourceBase m => MonadHandler (WidgetT site m) where instance MonadHandler (WidgetFor site) where
type HandlerSite (WidgetT site m) = site type HandlerSite (WidgetFor site) = site
liftHandlerT (HandlerT f) = WidgetT $ \_ref env -> liftIO $ f $ replaceToParent env liftHandler (HandlerFor f) = WidgetFor $ f . wdHandler
{-# RULES "liftHandlerT (WidgetT site IO)" forall f. liftHandlerT (HandlerT f) = WidgetT $ const f #-} {-# INLINE liftHandler #-}
#define GO(T) instance MonadHandler m => MonadHandler (T m) where type HandlerSite (T m) = HandlerSite m; liftHandlerT = lift . liftHandlerT #define GO(T) instance MonadHandler m => MonadHandler (T m) where type HandlerSite (T m) = HandlerSite m; liftHandler = lift . liftHandler
#define GOX(X, T) instance (X, MonadHandler m) => MonadHandler (T m) where type HandlerSite (T m) = HandlerSite m; liftHandlerT = lift . liftHandlerT #define GOX(X, T) instance (X, MonadHandler m) => MonadHandler (T m) where type HandlerSite (T m) = HandlerSite m; liftHandler = lift . liftHandler
GO(IdentityT) GO(IdentityT)
GO(ListT) GO(ListT)
GO(MaybeT) GO(MaybeT)
@ -70,12 +73,17 @@ GO(ConduitM i o)
#undef GOX #undef GOX
class MonadHandler m => MonadWidget m where class MonadHandler m => MonadWidget m where
liftWidgetT :: WidgetT (HandlerSite m) IO a -> m a liftWidget :: WidgetFor (HandlerSite m) a -> m a
instance MonadResourceBase m => MonadWidget (WidgetT site m) where instance MonadWidget (WidgetFor site) where
liftWidgetT (WidgetT f) = WidgetT $ \ref env -> liftIO $ f ref $ replaceToParent env liftWidget = id
{-# INLINE liftWidget #-}
#define GO(T) instance MonadWidget m => MonadWidget (T m) where liftWidgetT = lift . liftWidgetT liftWidgetT :: MonadWidget m => WidgetFor (HandlerSite m) a -> m a
#define GOX(X, T) instance (X, MonadWidget m) => MonadWidget (T m) where liftWidgetT = lift . liftWidgetT liftWidgetT = liftWidget
{-# DEPRECATED liftWidgetT "Use liftWidget instead" #-}
#define GO(T) instance MonadWidget m => MonadWidget (T m) where liftWidget = lift . liftWidget
#define GOX(X, T) instance (X, MonadWidget m) => MonadWidget (T m) where liftWidget = lift . liftWidget
GO(IdentityT) GO(IdentityT)
GO(ListT) GO(ListT)
GO(MaybeT) GO(MaybeT)

64
yesod-core/Yesod/Core/Class/Yesod.hs
View File

@ -56,7 +56,6 @@ import Web.Cookie (SetCookie (..), parseCookie
import Yesod.Core.Types import Yesod.Core.Types
import Yesod.Core.Internal.Session import Yesod.Core.Internal.Session
import Yesod.Core.Widget import Yesod.Core.Widget
import Control.Monad.Trans.Class (lift)
import Data.CaseInsensitive (CI) import Data.CaseInsensitive (CI)
import qualified Network.Wai.Request import qualified Network.Wai.Request
import Data.IORef import Data.IORef
@ -83,11 +82,11 @@ class RenderRoute site => Yesod site where
-- | Output error response pages. -- | Output error response pages.
-- --
-- Default value: 'defaultErrorHandler'. -- Default value: 'defaultErrorHandler'.
errorHandler :: ErrorResponse -> HandlerT site IO TypedContent errorHandler :: ErrorResponse -> HandlerFor site TypedContent
errorHandler = defaultErrorHandler errorHandler = defaultErrorHandler
-- | Applies some form of layout to the contents of a page. -- | Applies some form of layout to the contents of a page.
defaultLayout :: WidgetT site IO () -> HandlerT site IO Html defaultLayout :: WidgetFor site () -> HandlerFor site Html
defaultLayout w = do defaultLayout w = do
p <- widgetToPageContent w p <- widgetToPageContent w
msgs <- getMessages msgs <- getMessages
@ -139,7 +138,7 @@ class RenderRoute site => Yesod site where
-- If authentication is required, return 'AuthenticationRequired'. -- If authentication is required, return 'AuthenticationRequired'.
isAuthorized :: Route site isAuthorized :: Route site
-> Bool -- ^ is this a write request? -> Bool -- ^ is this a write request?
-> HandlerT site IO AuthResult -> HandlerFor site AuthResult
isAuthorized _ _ = return Authorized isAuthorized _ _ = return Authorized
-- | Determines whether the current request is a write request. By default, -- | Determines whether the current request is a write request. By default,
@ -149,7 +148,7 @@ class RenderRoute site => Yesod site where
-- --
-- This function is used to determine if a request is authorized; see -- This function is used to determine if a request is authorized; see
-- 'isAuthorized'. -- 'isAuthorized'.
isWriteRequest :: Route site -> HandlerT site IO Bool isWriteRequest :: Route site -> HandlerFor site Bool
isWriteRequest _ = do isWriteRequest _ = do
wai <- waiRequest wai <- waiRequest
return $ W.requestMethod wai `notElem` return $ W.requestMethod wai `notElem`
@ -215,7 +214,7 @@ class RenderRoute site => Yesod site where
addStaticContent :: Text -- ^ filename extension addStaticContent :: Text -- ^ filename extension
-> Text -- ^ mime-type -> Text -- ^ mime-type
-> L.ByteString -- ^ content -> L.ByteString -- ^ content
-> HandlerT site IO (Maybe (Either Text (Route site, [(Text, Text)]))) -> HandlerFor site (Maybe (Either Text (Route site, [(Text, Text)])))
addStaticContent _ _ _ = return Nothing addStaticContent _ _ _ = return Nothing
-- | Maximum allowed length of the request body, in bytes. -- | Maximum allowed length of the request body, in bytes.
@ -304,7 +303,7 @@ class RenderRoute site => Yesod site where
-- Default: the 'defaultYesodMiddleware' function. -- Default: the 'defaultYesodMiddleware' function.
-- --
-- Since: 1.1.6 -- Since: 1.1.6
yesodMiddleware :: ToTypedContent res => HandlerT site IO res -> HandlerT site IO res yesodMiddleware :: ToTypedContent res => HandlerFor site res -> HandlerFor site res
yesodMiddleware = defaultYesodMiddleware yesodMiddleware = defaultYesodMiddleware
-- | How to allocate an @InternalState@ for each request. -- | How to allocate an @InternalState@ for each request.
@ -325,7 +324,7 @@ class RenderRoute site => Yesod site where
-- primarily for wrapping up error messages for better display. -- primarily for wrapping up error messages for better display.
-- --
-- @since 1.4.30 -- @since 1.4.30
defaultMessageWidget :: Html -> HtmlUrl (Route site) -> WidgetT site IO () defaultMessageWidget :: Html -> HtmlUrl (Route site) -> WidgetFor site ()
defaultMessageWidget title body = do defaultMessageWidget title body = do
setTitle title setTitle title
toWidget toWidget
@ -384,7 +383,7 @@ defaultShouldLogIO a b = return $ defaultShouldLog a b
-- \"Vary: Accept, Accept-Language\" and performs authorization checks. -- \"Vary: Accept, Accept-Language\" and performs authorization checks.
-- --
-- Since 1.2.0 -- Since 1.2.0
defaultYesodMiddleware :: Yesod site => HandlerT site IO res -> HandlerT site IO res defaultYesodMiddleware :: Yesod site => HandlerFor site res -> HandlerFor site res
defaultYesodMiddleware handler = do defaultYesodMiddleware handler = do
addHeader "Vary" "Accept, Accept-Language" addHeader "Vary" "Accept, Accept-Language"
authorizationCheck authorizationCheck
@ -444,8 +443,8 @@ sameSiteSession s = (fmap . fmap) secureSessionCookies
-- --
-- Since 1.4.7 -- Since 1.4.7
sslOnlyMiddleware :: Int -- ^ minutes sslOnlyMiddleware :: Int -- ^ minutes
-> HandlerT site IO res -> HandlerFor site res
-> HandlerT site IO res -> HandlerFor site res
sslOnlyMiddleware timeout handler = do sslOnlyMiddleware timeout handler = do
addHeader "Strict-Transport-Security" addHeader "Strict-Transport-Security"
$ T.pack $ concat [ "max-age=" $ T.pack $ concat [ "max-age="
@ -458,7 +457,7 @@ sslOnlyMiddleware timeout handler = do
-- 'isWriteRequest'. -- 'isWriteRequest'.
-- --
-- Since 1.2.0 -- Since 1.2.0
authorizationCheck :: Yesod site => HandlerT site IO () authorizationCheck :: Yesod site => HandlerFor site ()
authorizationCheck = getCurrentRoute >>= maybe (return ()) checkUrl authorizationCheck = getCurrentRoute >>= maybe (return ()) checkUrl
where where
checkUrl url = do checkUrl url = do
@ -482,7 +481,7 @@ authorizationCheck = getCurrentRoute >>= maybe (return ()) checkUrl
-- | Calls 'csrfCheckMiddleware' with 'isWriteRequest', 'defaultCsrfHeaderName', and 'defaultCsrfParamName' as parameters. -- | Calls 'csrfCheckMiddleware' with 'isWriteRequest', 'defaultCsrfHeaderName', and 'defaultCsrfParamName' as parameters.
-- --
-- Since 1.4.14 -- Since 1.4.14
defaultCsrfCheckMiddleware :: Yesod site => HandlerT site IO res -> HandlerT site IO res defaultCsrfCheckMiddleware :: Yesod site => HandlerFor site res -> HandlerFor site res
defaultCsrfCheckMiddleware handler = defaultCsrfCheckMiddleware handler =
csrfCheckMiddleware csrfCheckMiddleware
handler handler
@ -496,11 +495,11 @@ defaultCsrfCheckMiddleware handler =
-- For details, see the "AJAX CSRF protection" section of "Yesod.Core.Handler". -- For details, see the "AJAX CSRF protection" section of "Yesod.Core.Handler".
-- --
-- Since 1.4.14 -- Since 1.4.14
csrfCheckMiddleware :: HandlerT site IO res csrfCheckMiddleware :: HandlerFor site res
-> HandlerT site IO Bool -- ^ Whether or not to perform the CSRF check. -> HandlerFor site Bool -- ^ Whether or not to perform the CSRF check.
-> CI S8.ByteString -- ^ The header name to lookup the CSRF token from. -> CI S8.ByteString -- ^ The header name to lookup the CSRF token from.
-> Text -- ^ The POST parameter name to lookup the CSRF token from. -> Text -- ^ The POST parameter name to lookup the CSRF token from.
-> HandlerT site IO res -> HandlerFor site res
csrfCheckMiddleware handler shouldCheckFn headerName paramName = do csrfCheckMiddleware handler shouldCheckFn headerName paramName = do
shouldCheck <- shouldCheckFn shouldCheck <- shouldCheckFn
when shouldCheck (checkCsrfHeaderOrParam headerName paramName) when shouldCheck (checkCsrfHeaderOrParam headerName paramName)
@ -511,7 +510,7 @@ csrfCheckMiddleware handler shouldCheckFn headerName paramName = do
-- The cookie's path is set to @/@, making it valid for your whole website. -- The cookie's path is set to @/@, making it valid for your whole website.
-- --
-- Since 1.4.14 -- Since 1.4.14
defaultCsrfSetCookieMiddleware :: HandlerT site IO res -> HandlerT site IO res defaultCsrfSetCookieMiddleware :: HandlerFor site res -> HandlerFor site res
defaultCsrfSetCookieMiddleware handler = setCsrfCookie >> handler defaultCsrfSetCookieMiddleware handler = setCsrfCookie >> handler
-- | Takes a 'SetCookie' and overrides its value with a CSRF token, then sets the cookie. See 'setCsrfCookieWithCookie'. -- | Takes a 'SetCookie' and overrides its value with a CSRF token, then sets the cookie. See 'setCsrfCookieWithCookie'.
@ -521,7 +520,7 @@ defaultCsrfSetCookieMiddleware handler = setCsrfCookie >> handler
-- Make sure to set the 'setCookiePath' to the root path of your application, otherwise you'll generate a new CSRF token for every path of your app. If your app is run from from e.g. www.example.com\/app1, use @app1@. The vast majority of sites will just use @/@. -- Make sure to set the 'setCookiePath' to the root path of your application, otherwise you'll generate a new CSRF token for every path of your app. If your app is run from from e.g. www.example.com\/app1, use @app1@. The vast majority of sites will just use @/@.
-- --
-- Since 1.4.14 -- Since 1.4.14
csrfSetCookieMiddleware :: HandlerT site IO res -> SetCookie -> HandlerT site IO res csrfSetCookieMiddleware :: HandlerFor site res -> SetCookie -> HandlerFor site res
csrfSetCookieMiddleware handler cookie = setCsrfCookieWithCookie cookie >> handler csrfSetCookieMiddleware handler cookie = setCsrfCookieWithCookie cookie >> handler
-- | Calls 'defaultCsrfSetCookieMiddleware' and 'defaultCsrfCheckMiddleware'. -- | Calls 'defaultCsrfSetCookieMiddleware' and 'defaultCsrfCheckMiddleware'.
@ -541,23 +540,26 @@ csrfSetCookieMiddleware handler cookie = setCsrfCookieWithCookie cookie >> handl
-- @ -- @
-- --
-- Since 1.4.14 -- Since 1.4.14
defaultCsrfMiddleware :: Yesod site => HandlerT site IO res -> HandlerT site IO res defaultCsrfMiddleware :: Yesod site => HandlerFor site res -> HandlerFor site res
defaultCsrfMiddleware = defaultCsrfSetCookieMiddleware . defaultCsrfCheckMiddleware defaultCsrfMiddleware = defaultCsrfSetCookieMiddleware . defaultCsrfCheckMiddleware
-- | Convert a widget to a 'PageContent'. -- | Convert a widget to a 'PageContent'.
widgetToPageContent :: Yesod site widgetToPageContent :: Yesod site
=> WidgetT site IO () => WidgetFor site ()
-> HandlerT site IO (PageContent (Route site)) -> HandlerFor site (PageContent (Route site))
widgetToPageContent w = do widgetToPageContent w = HandlerFor $ \hd -> do
master <- getYesod master <- unHandlerFor getYesod hd
hd <- HandlerT return ref <- newIORef mempty
ref <- lift $ newIORef mempty unWidgetFor w WidgetData
lift $ unWidgetT w ref hd { wdRef = ref
GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head') <- lift $ readIORef ref , wdHandler = hd
let title = maybe mempty unTitle mTitle }
scripts = runUniqueList scripts' GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head') <- readIORef ref
stylesheets = runUniqueList stylesheets' let title = maybe mempty unTitle mTitle
scripts = runUniqueList scripts'
stylesheets = runUniqueList stylesheets'
flip unHandlerFor hd $ do
render <- getUrlRenderParams render <- getUrlRenderParams
let renderLoc x = let renderLoc x =
case x of case x of
@ -645,7 +647,7 @@ widgetToPageContent w = do
runUniqueList (UniqueList x) = nub $ x [] runUniqueList (UniqueList x) = nub $ x []
-- | The default error handler for 'errorHandler'. -- | The default error handler for 'errorHandler'.
defaultErrorHandler :: Yesod site => ErrorResponse -> HandlerT site IO TypedContent defaultErrorHandler :: Yesod site => ErrorResponse -> HandlerFor site TypedContent
defaultErrorHandler NotFound = selectRep $ do defaultErrorHandler NotFound = selectRep $ do
provideRep $ defaultLayout $ do provideRep $ defaultLayout $ do
r <- waiRequest r <- waiRequest

1
yesod-core/Yesod/Core/Dispatch.hs
View File

@ -35,7 +35,6 @@ module Yesod.Core.Dispatch
-- * WAI subsites -- * WAI subsites
, WaiSubsite (..) , WaiSubsite (..)
, WaiSubsiteWithAuth (..) , WaiSubsiteWithAuth (..)
, subHelper
) where ) where
import Prelude hiding (exp) import Prelude hiding (exp)

57
yesod-core/Yesod/Core/Handler.hs
View File

@ -27,6 +27,7 @@
module Yesod.Core.Handler module Yesod.Core.Handler
( -- * Handler monad ( -- * Handler monad
HandlerT HandlerT
, HandlerFor
-- ** Read information from handler -- ** Read information from handler
, getYesod , getYesod
, getsYesod , getsYesod
@ -161,7 +162,6 @@ module Yesod.Core.Handler
-- * Per-request caching -- * Per-request caching
, cached , cached
, cachedBy , cachedBy
, stripHandlerT
-- * AJAX CSRF protection -- * AJAX CSRF protection
-- $ajaxCSRFOverview -- $ajaxCSRFOverview
@ -254,14 +254,17 @@ import qualified Data.Foldable as Fold
import Data.Default import Data.Default
import Control.Monad.Logger (MonadLogger, logWarnS) import Control.Monad.Logger (MonadLogger, logWarnS)
type HandlerT site (m :: * -> *) = HandlerFor site
{-# DEPRECATED HandlerT "Use HandlerFor directly" #-}
get :: MonadHandler m => m GHState get :: MonadHandler m => m GHState
get = liftHandlerT $ HandlerT $ I.readIORef . handlerState get = liftHandler $ HandlerFor $ I.readIORef . handlerState
put :: MonadHandler m => GHState -> m () put :: MonadHandler m => GHState -> m ()
put x = liftHandlerT $ HandlerT $ flip I.writeIORef x . handlerState put x = liftHandler $ HandlerFor $ flip I.writeIORef x . handlerState
modify :: MonadHandler m => (GHState -> GHState) -> m () modify :: MonadHandler m => (GHState -> GHState) -> m ()
modify f = liftHandlerT $ HandlerT $ flip I.modifyIORef f . handlerState modify f = liftHandler $ HandlerFor $ flip I.modifyIORef f . handlerState
tell :: MonadHandler m => Endo [Header] -> m () tell :: MonadHandler m => Endo [Header] -> m ()
tell hs = modify $ \g -> g { ghsHeaders = ghsHeaders g `mappend` hs } tell hs = modify $ \g -> g { ghsHeaders = ghsHeaders g `mappend` hs }
@ -273,14 +276,14 @@ hcError :: MonadHandler m => ErrorResponse -> m a
hcError = handlerError . HCError hcError = handlerError . HCError
getRequest :: MonadHandler m => m YesodRequest getRequest :: MonadHandler m => m YesodRequest
getRequest = liftHandlerT $ HandlerT $ return . handlerRequest getRequest = liftHandler $ HandlerFor $ return . handlerRequest
runRequestBody :: MonadHandler m => m RequestBodyContents runRequestBody :: MonadHandler m => m RequestBodyContents
runRequestBody = do runRequestBody = do
HandlerData HandlerData
{ handlerEnv = RunHandlerEnv {..} { handlerEnv = RunHandlerEnv {..}
, handlerRequest = req , handlerRequest = req
} <- liftHandlerT $ HandlerT return } <- liftHandler $ HandlerFor return
let len = W.requestBodyLength $ reqWaiRequest req let len = W.requestBodyLength $ reqWaiRequest req
upload = rheUpload len upload = rheUpload len
x <- get x <- get
@ -320,7 +323,7 @@ rbHelper' backend mkFI req =
go = decodeUtf8With lenientDecode go = decodeUtf8With lenientDecode
askHandlerEnv :: MonadHandler m => m (RunHandlerEnv (HandlerSite m)) askHandlerEnv :: MonadHandler m => m (RunHandlerEnv (HandlerSite m))
askHandlerEnv = liftHandlerT $ HandlerT $ return . handlerEnv askHandlerEnv = liftHandler $ HandlerFor $ return . handlerEnv
-- | Get the master site application argument. -- | Get the master site application argument.
getYesod :: MonadHandler m => m (HandlerSite m) getYesod :: MonadHandler m => m (HandlerSite m)
@ -396,9 +399,9 @@ getCurrentRoute = rheRoute <$> askHandlerEnv
-- This allows the inner 'GHandler' to outlive the outer -- This allows the inner 'GHandler' to outlive the outer
-- 'GHandler' (e.g., on the @forkIO@ example above, a response -- 'GHandler' (e.g., on the @forkIO@ example above, a response
-- may be sent to the client without killing the new thread). -- may be sent to the client without killing the new thread).
handlerToIO :: (MonadIO m1, MonadIO m2) => HandlerT site m1 (HandlerT site IO a -> m2 a) handlerToIO :: MonadIO m => HandlerFor site (HandlerFor site a -> m a)
handlerToIO = handlerToIO =
HandlerT $ \oldHandlerData -> do HandlerFor $ \oldHandlerData -> do
-- Take just the bits we need from oldHandlerData. -- Take just the bits we need from oldHandlerData.
let newReq = oldReq { reqWaiRequest = newWaiReq } let newReq = oldReq { reqWaiRequest = newWaiReq }
where where
@ -420,7 +423,7 @@ handlerToIO =
liftIO $ evaluate (newReq `seq` oldEnv `seq` newState `seq` ()) liftIO $ evaluate (newReq `seq` oldEnv `seq` newState `seq` ())
-- Return GHandler running function. -- Return GHandler running function.
return $ \(HandlerT f) -> return $ \(HandlerFor f) ->
liftIO $ liftIO $
runResourceT $ withInternalState $ \resState -> do runResourceT $ withInternalState $ \resState -> do
-- The state IORef needs to be created here, otherwise it -- The state IORef needs to be created here, otherwise it
@ -431,7 +434,6 @@ handlerToIO =
{ handlerRequest = newReq { handlerRequest = newReq
, handlerEnv = oldEnv , handlerEnv = oldEnv
, handlerState = newStateIORef , handlerState = newStateIORef
, handlerToParent = const ()
, handlerResource = resState , handlerResource = resState
} }
liftIO (f newHandlerData) liftIO (f newHandlerData)
@ -442,9 +444,9 @@ handlerToIO =
-- for correctness and efficiency -- for correctness and efficiency
-- --
-- @since 1.2.8 -- @since 1.2.8
forkHandler :: (SomeException -> HandlerT site IO ()) -- ^ error handler forkHandler :: (SomeException -> HandlerFor site ()) -- ^ error handler
-> HandlerT site IO () -> HandlerFor site ()
-> HandlerT site IO () -> HandlerFor site ()
forkHandler onErr handler = do forkHandler onErr handler = do
yesRunner <- handlerToIO yesRunner <- handlerToIO
void $ liftResourceT $ resourceForkIO $ yesRunner $ handle onErr handler void $ liftResourceT $ resourceForkIO $ yesRunner $ handle onErr handler
@ -1370,14 +1372,14 @@ respond ct = return . TypedContent ct . toContent
-- --
-- @since 1.2.0 -- @since 1.2.0
respondSource :: ContentType respondSource :: ContentType
-> Source (HandlerT site IO) (Flush Builder) -> Source (HandlerFor site) (Flush Builder)
-> HandlerT site IO TypedContent -> HandlerFor site TypedContent
respondSource ctype src = HandlerT $ \hd -> respondSource ctype src = HandlerFor $ \hd ->
-- Note that this implementation relies on the fact that the ResourceT -- Note that this implementation relies on the fact that the ResourceT
-- environment provided by the server is the same one used in HandlerT. -- environment provided by the server is the same one used in HandlerT.
-- This is a safe assumption assuming the HandlerT is run correctly. -- This is a safe assumption assuming the HandlerT is run correctly.
return $ TypedContent ctype $ ContentSource return $ TypedContent ctype $ ContentSource
$ transPipe (lift . flip unHandlerT hd) src $ transPipe (lift . flip unHandlerFor hd) src
-- | In a streaming response, send a single chunk of data. This function works -- | In a streaming response, send a single chunk of data. This function works
-- on most datatypes, such as @ByteString@ and @Html@. -- on most datatypes, such as @ByteString@ and @Html@.
@ -1423,25 +1425,6 @@ sendChunkLazyText = sendChunk
sendChunkHtml :: Monad m => Html -> Producer m (Flush Builder) sendChunkHtml :: Monad m => Html -> Producer m (Flush Builder)
sendChunkHtml = sendChunk sendChunkHtml = sendChunk
-- | Converts a child handler to a parent handler
--
-- Exported since 1.4.11
stripHandlerT :: HandlerT child (HandlerT parent m) a
-> (parent -> child)
-> (Route child -> Route parent)
-> Maybe (Route child)
-> HandlerT parent m a
stripHandlerT (HandlerT f) getSub toMaster newRoute = HandlerT $ \hd -> do
let env = handlerEnv hd
($ hd) $ unHandlerT $ f hd
{ handlerEnv = env
{ rheSite = getSub $ rheSite env
, rheRoute = newRoute
, rheRender = \url params -> rheRender env (toMaster url) params
}
, handlerToParent = toMaster
}
-- $ajaxCSRFOverview -- $ajaxCSRFOverview
-- When a user has authenticated with your site, all requests made from the browser to your server will include the session information that you use to verify that the user is logged in. -- When a user has authenticated with your site, all requests made from the browser to your server will include the session information that you use to verify that the user is logged in.
-- Unfortunately, this allows attackers to make unwanted requests on behalf of the user by e.g. submitting an HTTP request to your site when the user visits theirs. -- Unfortunately, this allows attackers to make unwanted requests on behalf of the user by e.g. submitting an HTTP request to your site when the user visits theirs.

4
yesod-core/Yesod/Core/Internal/LiteApp.hs
View File

@ -46,8 +46,8 @@ instance Monoid LiteApp where
mempty = LiteApp $ \_ _ -> Nothing mempty = LiteApp $ \_ _ -> Nothing
mappend (LiteApp x) (LiteApp y) = LiteApp $ \m ps -> x m ps <|> y m ps mappend (LiteApp x) (LiteApp y) = LiteApp $ \m ps -> x m ps <|> y m ps
type LiteHandler = HandlerT LiteApp IO type LiteHandler = HandlerFor LiteApp
type LiteWidget = WidgetT LiteApp IO type LiteWidget = WidgetFor LiteApp
liteApp :: Writer LiteApp () -> LiteApp liteApp :: Writer LiteApp () -> LiteApp
liteApp = execWriter liteApp = execWriter

11
yesod-core/Yesod/Core/Internal/Run.hs
View File

@ -83,7 +83,7 @@ errFromShow x = evaluate $!! InternalError $! T.pack $! show x
-- represented by the @HandlerContents@. -- represented by the @HandlerContents@.
basicRunHandler :: ToTypedContent c basicRunHandler :: ToTypedContent c
=> RunHandlerEnv site => RunHandlerEnv site
-> HandlerT site IO c -> HandlerFor site c
-> YesodRequest -> YesodRequest
-> InternalState -> InternalState
-> IO (GHState, HandlerContents) -> IO (GHState, HandlerContents)
@ -96,7 +96,7 @@ basicRunHandler rhe handler yreq resState = do
-- converting them into a @HandlerContents@ -- converting them into a @HandlerContents@
contents' <- catchSync contents' <- catchSync
(do (do
res <- unHandlerT handler (hd istate) res <- unHandlerFor handler (hd istate)
tc <- evaluate (toTypedContent res) tc <- evaluate (toTypedContent res)
-- Success! Wrap it up in an @HCContent@ -- Success! Wrap it up in an @HCContent@
return (HCContent defaultStatus tc)) return (HCContent defaultStatus tc))
@ -121,7 +121,6 @@ basicRunHandler rhe handler yreq resState = do
{ handlerRequest = yreq { handlerRequest = yreq
, handlerEnv = rhe , handlerEnv = rhe
, handlerState = istate , handlerState = istate
, handlerToParent = const ()
, handlerResource = resState , handlerResource = resState
} }
@ -208,7 +207,7 @@ evalFallback contents val = catchSync
-- 'HandlerT' into an 'Application'. Should not be needed by users. -- 'HandlerT' into an 'Application'. Should not be needed by users.
runHandler :: ToTypedContent c runHandler :: ToTypedContent c
=> RunHandlerEnv site => RunHandlerEnv site
-> HandlerT site IO c -> HandlerFor site c
-> YesodApp -> YesodApp
runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -> do runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -> do
-- Get the raw state and original contents -- Get the raw state and original contents
@ -263,7 +262,7 @@ runFakeHandler :: (Yesod site, MonadIO m) =>
SessionMap SessionMap
-> (site -> Logger) -> (site -> Logger)
-> site -> site
-> HandlerT site IO a -> HandlerFor site a
-> m (Either ErrorResponse a) -> m (Either ErrorResponse a)
runFakeHandler fakeSessionMap logger site handler = liftIO $ do runFakeHandler fakeSessionMap logger site handler = liftIO $ do
ret <- I.newIORef (Left $ InternalError "runFakeHandler: no result") ret <- I.newIORef (Left $ InternalError "runFakeHandler: no result")
@ -322,7 +321,7 @@ runFakeHandler fakeSessionMap logger site handler = liftIO $ do
I.readIORef ret I.readIORef ret
yesodRunner :: (ToTypedContent res, Yesod site) yesodRunner :: (ToTypedContent res, Yesod site)
=> HandlerT site IO res => HandlerFor site res
-> YesodRunnerEnv site -> YesodRunnerEnv site
-> Maybe (Route site) -> Maybe (Route site)
-> Application -> Application

9
yesod-core/Yesod/Core/Internal/TH.hs
View File

@ -32,7 +32,6 @@ import Text.ParserCombinators.Parsec.Char (alphaNum, spaces, string, char)
import Yesod.Routes.TH import Yesod.Routes.TH
import Yesod.Routes.Parse import Yesod.Routes.Parse
import Yesod.Core.Types import Yesod.Core.Types
import Yesod.Core.Content
import Yesod.Core.Class.Dispatch import Yesod.Core.Class.Dispatch
import Yesod.Core.Internal.Run import Yesod.Core.Internal.Run
@ -102,12 +101,12 @@ mkYesodDispatch :: String -> [ResourceTree String] -> Q [Dec]
mkYesodDispatch name = fmap snd . mkYesodGeneral name [] False return mkYesodDispatch name = fmap snd . mkYesodGeneral name [] False return
-- | Get the Handler and Widget type synonyms for the given site. -- | Get the Handler and Widget type synonyms for the given site.
masterTypeSyns :: [Name] -> Type -> [Dec] masterTypeSyns :: [Name] -> Type -> [Dec] -- FIXME remove from here, put into the scaffolding itself?
masterTypeSyns vs site = masterTypeSyns vs site =
[ TySynD (mkName "Handler") (fmap PlainTV vs) [ TySynD (mkName "Handler") (fmap PlainTV vs)
$ ConT ''HandlerT `AppT` site `AppT` ConT ''IO $ ConT ''HandlerFor `AppT` site
, TySynD (mkName "Widget") (fmap PlainTV vs) , TySynD (mkName "Widget") (fmap PlainTV vs)
$ ConT ''WidgetT `AppT` site `AppT` ConT ''IO `AppT` ConT ''() $ ConT ''WidgetFor `AppT` site `AppT` ConT ''()
] ]
-- | 'Left' arguments indicate a monomorphic type, a 'Right' argument -- | 'Left' arguments indicate a monomorphic type, a 'Right' argument
@ -242,7 +241,7 @@ mkDispatchInstance master cxt f res = do
mkYesodSubDispatch :: [ResourceTree a] -> Q Exp mkYesodSubDispatch :: [ResourceTree a] -> Q Exp
mkYesodSubDispatch res = do mkYesodSubDispatch res = do
clause' <- mkDispatchClause (mkMDS return [|subHelper . fmap toTypedContent|]) res clause' <- mkDispatchClause (mkMDS return [|subHelper|]) res
inner <- newName "inner" inner <- newName "inner"
let innerFun = FunD inner [clause'] let innerFun = FunD inner [clause']
helper <- newName "helper" helper <- newName "helper"

10
yesod-core/Yesod/Core/Json.hs
View File

@ -31,14 +31,14 @@ module Yesod.Core.Json
, acceptsJson , acceptsJson
) where ) where
import Yesod.Core.Handler (HandlerT, getRequest, invalidArgs, redirect, selectRep, provideRep, rawRequestBody, ProvidedRep, lookupHeader) import Yesod.Core.Handler (HandlerFor, getRequest, invalidArgs, redirect, selectRep, provideRep, rawRequestBody, ProvidedRep, lookupHeader)
import Control.Monad.Trans.Writer (Writer) import Control.Monad.Trans.Writer (Writer)
import Data.Monoid (Endo) import Data.Monoid (Endo)
import Yesod.Core.Content (TypedContent) import Yesod.Core.Content (TypedContent)
import Yesod.Core.Types (reqAccept) import Yesod.Core.Types (reqAccept)
import Yesod.Core.Class.Yesod (defaultLayout, Yesod) import Yesod.Core.Class.Yesod (defaultLayout, Yesod)
import Yesod.Core.Class.Handler import Yesod.Core.Class.Handler
import Yesod.Core.Widget (WidgetT) import Yesod.Core.Widget (WidgetFor)
import Yesod.Routes.Class import Yesod.Routes.Class
import qualified Data.Aeson as J import qualified Data.Aeson as J
import qualified Data.Aeson.Parser as JP import qualified Data.Aeson.Parser as JP
@ -58,9 +58,9 @@ import Control.Monad (liftM)
-- --
-- @since 0.3.0 -- @since 0.3.0
defaultLayoutJson :: (Yesod site, J.ToJSON a) defaultLayoutJson :: (Yesod site, J.ToJSON a)
=> WidgetT site IO () -- ^ HTML => WidgetFor site () -- ^ HTML
-> HandlerT site IO a -- ^ JSON -> HandlerFor site a -- ^ JSON
-> HandlerT site IO TypedContent -> HandlerFor site TypedContent
defaultLayoutJson w json = selectRep $ do defaultLayoutJson w json = selectRep $ do
provideRep $ defaultLayout w provideRep $ defaultLayout w
provideRep $ fmap J.toEncoding json provideRep $ fmap J.toEncoding json

226
yesod-core/Yesod/Core/Types.hs
View File

@ -1,4 +1,5 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TupleSections #-} {-# LANGUAGE TupleSections #-}
@ -18,14 +19,14 @@ import Data.Monoid (Monoid (..))
#endif #endif
import Control.Arrow (first) import Control.Arrow (first)
import Control.Exception (Exception) import Control.Exception (Exception)
import Control.Monad (liftM, ap) import Control.Monad (ap)
import Control.Monad.Base (MonadBase (liftBase)) import Control.Monad.Base (MonadBase (liftBase))
import Control.Monad.Catch (MonadMask (..), MonadCatch (..)) import Control.Monad.Catch (MonadMask (..), MonadCatch (..))
import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.IO.Class (MonadIO (liftIO))
import Control.Monad.Logger (LogLevel, LogSource, import Control.Monad.Logger (LogLevel, LogSource,
MonadLogger (..)) MonadLogger (..))
import Control.Monad.Trans.Control (MonadBaseControl (..)) import Control.Monad.Trans.Control (MonadBaseControl (..))
import Control.Monad.Trans.Resource (MonadResource (..), InternalState, runInternalState, MonadThrow (..), monadThrow, ResourceT) import Control.Monad.Trans.Resource (MonadResource (..), InternalState, runInternalState, MonadThrow (..), ResourceT)
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
import Data.Conduit (Flush, Source) import Data.Conduit (Flush, Source)
@ -56,7 +57,6 @@ import Text.Hamlet (HtmlUrl)
import Text.Julius (JavascriptUrl) import Text.Julius (JavascriptUrl)
import Web.Cookie (SetCookie) import Web.Cookie (SetCookie)
import Yesod.Core.Internal.Util (getTime, putTime) import Yesod.Core.Internal.Util (getTime, putTime)
import Control.Monad.Trans.Class (MonadTrans (..))
import Yesod.Routes.Class (RenderRoute (..), ParseRoute (..)) import Yesod.Routes.Class (RenderRoute (..), ParseRoute (..))
import Control.Monad.Reader (MonadReader (..)) import Control.Monad.Reader (MonadReader (..))
import Data.Monoid ((<>)) import Data.Monoid ((<>))
@ -66,7 +66,7 @@ import Data.Conduit.Lazy (MonadActive, monadActive)
import Yesod.Core.TypeCache (TypeMap, KeyedTypeMap) import Yesod.Core.TypeCache (TypeMap, KeyedTypeMap)
import Control.Monad.Logger (MonadLoggerIO (..)) import Control.Monad.Logger (MonadLoggerIO (..))
import Data.Semigroup (Semigroup) import Data.Semigroup (Semigroup)
import Control.Monad.IO.Unlift (MonadUnliftIO (..), UnliftIO (..), withUnliftIO) import Control.Monad.IO.Unlift (MonadUnliftIO (..), UnliftIO (..))
-- Sessions -- Sessions
type SessionMap = Map Text ByteString type SessionMap = Map Text ByteString
@ -193,11 +193,10 @@ data RunHandlerEnv site = RunHandlerEnv
, rheMaxExpires :: !Text , rheMaxExpires :: !Text
} }
data HandlerData site parentRoute = HandlerData data HandlerData site = HandlerData
{ handlerRequest :: !YesodRequest { handlerRequest :: !YesodRequest
, handlerEnv :: !(RunHandlerEnv site) , handlerEnv :: !(RunHandlerEnv site)
, handlerState :: !(IORef GHState) , handlerState :: !(IORef GHState)
, handlerToParent :: !(Route site -> parentRoute)
, handlerResource :: !InternalState , handlerResource :: !InternalState
} }
@ -224,16 +223,13 @@ type ParentRunner parent m
-- | A generic handler monad, which can have a different subsite and master -- | A generic handler monad, which can have a different subsite and master
-- site. We define a newtype for better error message. -- site. We define a newtype for better error message.
newtype HandlerT site m a = HandlerT newtype HandlerFor site a = HandlerFor
{ unHandlerT :: HandlerData site (MonadRoute m) -> m a { unHandlerFor :: HandlerData site -> IO a
} }
deriving Functor
type family MonadRoute (m :: * -> *)
type instance MonadRoute IO = ()
type instance MonadRoute (HandlerT site m) = (Route site)
data GHState = GHState data GHState = GHState
{ ghsSession :: SessionMap { ghsSession :: !SessionMap
, ghsRBC :: Maybe RequestBodyContents , ghsRBC :: Maybe RequestBodyContents
, ghsIdent :: Int , ghsIdent :: Int
, ghsCache :: TypeMap , ghsCache :: TypeMap
@ -249,26 +245,32 @@ type YesodApp = YesodRequest -> ResourceT IO YesodResponse
-- | A generic widget, allowing specification of both the subsite and master -- | A generic widget, allowing specification of both the subsite and master
-- site datatypes. While this is simply a @WriterT@, we define a newtype for -- site datatypes. While this is simply a @WriterT@, we define a newtype for
-- better error messages. -- better error messages.
newtype WidgetT site m a = WidgetT newtype WidgetFor site a = WidgetFor
{ unWidgetT :: IORef (GWData (Route site)) -> HandlerData site (MonadRoute m) -> m a { unWidgetFor :: WidgetData site -> IO a
} }
deriving Functor
instance (a ~ (), Monad m) => Monoid (WidgetT site m a) where data WidgetData site = WidgetData
{ wdRef :: {-# UNPACK #-} !(IORef (GWData (Route site)))
, wdHandler :: {-# UNPACK #-} !(HandlerData site)
}
instance a ~ () => Monoid (WidgetFor site a) where
mempty = return () mempty = return ()
mappend x y = x >> y mappend x y = x >> y
instance (a ~ (), Monad m) => Semigroup (WidgetT site m a) instance a ~ () => Semigroup (WidgetFor site a)
-- | A 'String' can be trivially promoted to a widget. -- | A 'String' can be trivially promoted to a widget.
-- --
-- For example, in a yesod-scaffold site you could use: -- For example, in a yesod-scaffold site you could use:
-- --
-- @getHomeR = do defaultLayout "Widget text"@ -- @getHomeR = do defaultLayout "Widget text"@
instance (MonadIO m, a ~ ()) => IsString (WidgetT site m a) where -- FIXME turn it into WidgetFor? instance a ~ () => IsString (WidgetFor site a) where
fromString = toWidget . toHtml . T.pack fromString = toWidget . toHtml . T.pack
where toWidget x = tellWidget mempty { gwdBody = Body (const x) } where toWidget x = tellWidget mempty { gwdBody = Body (const x) }
tellWidget :: MonadIO m => GWData (Route site) -> WidgetT site m () tellWidget :: GWData (Route site) -> WidgetFor site ()
tellWidget d = WidgetT $ \ref _ -> liftIO $ modifyIORef' ref (<> d) tellWidget d = WidgetFor $ \wd -> modifyIORef' (wdRef wd) (<> d)
type RY master = Route master -> [(Text, Text)] -> Text type RY master = Route master -> [(Text, Text)] -> Text
@ -404,106 +406,85 @@ instance Show HandlerContents where
show (HCWaiApp _) = "HCWaiApp" show (HCWaiApp _) = "HCWaiApp"
instance Exception HandlerContents instance Exception HandlerContents
-- Instances for WidgetT -- Instances for WidgetFor
instance Monad m => Functor (WidgetT site m) where instance Applicative (WidgetFor site) where
fmap = liftM pure = WidgetFor . const . pure
instance Monad m => Applicative (WidgetT site m) where
pure = return
(<*>) = ap (<*>) = ap
instance Monad m => Monad (WidgetT site m) where instance Monad (WidgetFor site) where
return a = WidgetT $ \_ _ -> return a return = pure
WidgetT x >>= f = WidgetT $ \ref r -> do WidgetFor x >>= f = WidgetFor $ \wd -> do
a <- x ref r a <- x wd
unWidgetT (f a) ref r unWidgetFor (f a) wd
instance MonadIO m => MonadIO (WidgetT site m) where instance MonadIO (WidgetFor site) where
liftIO = lift . liftIO liftIO = WidgetFor . const
instance MonadBase b m => MonadBase b (WidgetT site m) where instance b ~ IO => MonadBase b (WidgetFor site) where
liftBase = WidgetT . const . const . liftBase liftBase = WidgetFor . const
instance MonadBaseControl b m => MonadBaseControl b (WidgetT site m) where instance b ~ IO => MonadBaseControl b (WidgetFor site) where
type StM (WidgetT site m) a = StM m a type StM (WidgetFor site) a = a
liftBaseWith f = WidgetT $ \ref reader' -> liftBaseWith f = WidgetFor $ \wd ->
liftBaseWith $ \runInBase -> liftBaseWith $ \runInBase ->
f $ runInBase . (\(WidgetT w) -> w ref reader') f $ runInBase . (flip unWidgetFor wd)
restoreM = WidgetT . const . const . restoreM restoreM = WidgetFor . const . return
-- | @since 1.4.38 -- | @since 1.4.38
instance MonadUnliftIO m => MonadUnliftIO (WidgetT site m) where instance MonadUnliftIO (WidgetFor site) where
{-# INLINE askUnliftIO #-} {-# INLINE askUnliftIO #-}
askUnliftIO = WidgetT $ \ref r -> askUnliftIO = WidgetFor $ \wd ->
withUnliftIO $ \u -> return (UnliftIO (flip unWidgetFor wd))
return (UnliftIO (\(WidgetT w) -> unliftIO u $ w ref r)) instance MonadReader (WidgetData site) (WidgetFor site) where
instance Monad m => MonadReader site (WidgetT site m) where ask = WidgetFor return
ask = WidgetT $ \_ hd -> return (rheSite $ handlerEnv hd) local f (WidgetFor g) = WidgetFor $ g . f
local f (WidgetT g) = WidgetT $ \ref hd -> g ref hd
{ handlerEnv = (handlerEnv hd)
{ rheSite = f $ rheSite $ handlerEnv hd
}
}
instance MonadTrans (WidgetT site) where instance MonadThrow (WidgetFor site) where
lift = WidgetT . const . const throwM = liftIO . throwM
instance MonadThrow m => MonadThrow (WidgetT site m) where
throwM = lift . throwM
instance MonadCatch m => MonadCatch (HandlerT site m) where instance MonadCatch (HandlerFor site) where
catch (HandlerT m) c = HandlerT $ \r -> m r `catch` \e -> unHandlerT (c e) r catch (HandlerFor m) c = HandlerFor $ \r -> m r `catch` \e -> unHandlerFor (c e) r
instance MonadMask m => MonadMask (HandlerT site m) where instance MonadMask (HandlerFor site) where
mask a = HandlerT $ \e -> mask $ \u -> unHandlerT (a $ q u) e mask a = HandlerFor $ \e -> mask $ \u -> unHandlerFor (a $ q u) e
where q u (HandlerT b) = HandlerT (u . b) where q u (HandlerFor b) = HandlerFor (u . b)
uninterruptibleMask a = uninterruptibleMask a =
HandlerT $ \e -> uninterruptibleMask $ \u -> unHandlerT (a $ q u) e HandlerFor $ \e -> uninterruptibleMask $ \u -> unHandlerFor (a $ q u) e
where q u (HandlerT b) = HandlerT (u . b) where q u (HandlerFor b) = HandlerFor (u . b)
instance MonadCatch m => MonadCatch (WidgetT site m) where instance MonadCatch (WidgetFor site) where
catch (WidgetT m) c = WidgetT $ \ref r -> m ref r `catch` \e -> unWidgetT (c e) ref r catch (WidgetFor m) c = WidgetFor $ \r -> m r `catch` \e -> unWidgetFor (c e) r
instance MonadMask m => MonadMask (WidgetT site m) where instance MonadMask (WidgetFor site) where
mask a = WidgetT $ \ref e -> mask $ \u -> unWidgetT (a $ q u) ref e mask a = WidgetFor $ \e -> mask $ \u -> unWidgetFor (a $ q u) e
where q u (WidgetT b) = WidgetT (\ref e -> u $ b ref e) where q u (WidgetFor b) = WidgetFor (u . b)
uninterruptibleMask a = uninterruptibleMask a =
WidgetT $ \ref e -> uninterruptibleMask $ \u -> unWidgetT (a $ q u) ref e WidgetFor $ \e -> uninterruptibleMask $ \u -> unWidgetFor (a $ q u) e
where q u (WidgetT b) = WidgetT (\ref e -> u $ b ref e) where q u (WidgetFor b) = WidgetFor (u . b)
-- CPP to avoid a redundant constraints warning instance MonadResource (WidgetFor site) where
#if MIN_VERSION_base(4,9,0) liftResourceT f = WidgetFor $ runInternalState f . handlerResource . wdHandler
instance (MonadIO m, MonadBase IO m, MonadThrow m) => MonadResource (WidgetT site m) where
#else
instance (Applicative m, MonadIO m, MonadBase IO m, MonadThrow m) => MonadResource (WidgetT site m) where
#endif
liftResourceT f = WidgetT $ \_ hd -> liftIO $ runInternalState f (handlerResource hd)
instance MonadIO m => MonadLogger (WidgetT site m) where instance MonadLogger (WidgetFor site) where
monadLoggerLog a b c d = WidgetT $ \_ hd -> monadLoggerLog a b c d = WidgetFor $ \wd ->
liftIO $ rheLog (handlerEnv hd) a b c (toLogStr d) rheLog (handlerEnv $ wdHandler wd) a b c (toLogStr d)
instance MonadIO m => MonadLoggerIO (WidgetT site m) where instance MonadLoggerIO (WidgetFor site) where
askLoggerIO = WidgetT $ \_ hd -> return $ rheLog $ handlerEnv hd askLoggerIO = WidgetFor $ return . rheLog . handlerEnv . wdHandler
instance MonadActive m => MonadActive (WidgetT site m) where -- FIXME look at implementation of ResourceT
monadActive = lift monadActive instance MonadActive (WidgetFor site) where
instance MonadActive m => MonadActive (HandlerT site m) where monadActive = liftIO monadActive
monadActive = lift monadActive instance MonadActive (HandlerFor site) where
monadActive = liftIO monadActive
instance MonadTrans (HandlerT site) where
lift = HandlerT . const
-- Instances for HandlerT -- Instances for HandlerT
instance Monad m => Functor (HandlerT site m) where instance Applicative (HandlerFor site) where
fmap = liftM pure = HandlerFor . const . return
instance Monad m => Applicative (HandlerT site m) where
pure = return
(<*>) = ap (<*>) = ap
instance Monad m => Monad (HandlerT site m) where instance Monad (HandlerFor site) where
return = HandlerT . const . return return = pure
HandlerT x >>= f = HandlerT $ \r -> x r >>= \x' -> unHandlerT (f x') r HandlerFor x >>= f = HandlerFor $ \r -> x r >>= \x' -> unHandlerFor (f x') r
instance MonadIO m => MonadIO (HandlerT site m) where instance MonadIO (HandlerFor site) where
liftIO = lift . liftIO liftIO = HandlerFor . const
instance MonadBase b m => MonadBase b (HandlerT site m) where instance b ~ IO => MonadBase b (HandlerFor site) where
liftBase = lift . liftBase liftBase = liftIO
instance Monad m => MonadReader site (HandlerT site m) where instance MonadReader (HandlerData site) (HandlerFor site) where
ask = HandlerT $ return . rheSite . handlerEnv ask = HandlerFor return
local f (HandlerT g) = HandlerT $ \hd -> g hd local f (HandlerFor g) = HandlerFor $ g . f
{ handlerEnv = (handlerEnv hd)
{ rheSite = f $ rheSite $ handlerEnv hd
}
}
-- | Note: although we provide a @MonadBaseControl@ instance, @lifted-base@'s -- | Note: although we provide a @MonadBaseControl@ instance, @lifted-base@'s
-- @fork@ function is incompatible with the underlying @ResourceT@ system. -- @fork@ function is incompatible with the underlying @ResourceT@ system.
-- Instead, if you must fork a separate thread, you should use -- Instead, if you must fork a separate thread, you should use
@ -512,31 +493,30 @@ instance Monad m => MonadReader site (HandlerT site m) where
-- Using fork usually leads to an exception that says -- Using fork usually leads to an exception that says
-- \"Control.Monad.Trans.Resource.register\': The mutable state is being accessed -- \"Control.Monad.Trans.Resource.register\': The mutable state is being accessed
-- after cleanup. Please contact the maintainers.\" -- after cleanup. Please contact the maintainers.\"
instance MonadBaseControl b m => MonadBaseControl b (HandlerT site m) where instance b ~ IO => MonadBaseControl b (HandlerFor site) where
type StM (HandlerT site m) a = StM m a type StM (HandlerFor site) a = a
liftBaseWith f = HandlerT $ \reader' -> liftBaseWith f = HandlerFor $ \reader' ->
liftBaseWith $ \runInBase -> liftBaseWith $ \runInBase ->
f $ runInBase . (\(HandlerT r) -> r reader') f $ runInBase . (flip unHandlerFor reader')
restoreM = HandlerT . const . restoreM restoreM = HandlerFor . const . return
-- | @since 1.4.38 -- | @since 1.4.38
instance MonadUnliftIO m => MonadUnliftIO (HandlerT site m) where instance MonadUnliftIO (HandlerFor site) where
{-# INLINE askUnliftIO #-} {-# INLINE askUnliftIO #-}
askUnliftIO = HandlerT $ \r -> askUnliftIO = HandlerFor $ \r ->
withUnliftIO $ \u -> return (UnliftIO (flip unHandlerFor r))
return (UnliftIO (unliftIO u . flip unHandlerT r))
instance MonadThrow m => MonadThrow (HandlerT site m) where instance MonadThrow (HandlerFor site) where
throwM = lift . monadThrow throwM = liftIO . throwM
instance (MonadIO m, MonadBase IO m, MonadThrow m) => MonadResource (HandlerT site m) where instance MonadResource (HandlerFor site) where
liftResourceT f = HandlerT $ \hd -> liftIO $ runInternalState f (handlerResource hd) liftResourceT f = HandlerFor $ runInternalState f . handlerResource
instance MonadIO m => MonadLogger (HandlerT site m) where instance MonadLogger (HandlerFor site) where
monadLoggerLog a b c d = HandlerT $ \hd -> monadLoggerLog a b c d = HandlerFor $ \hd ->
liftIO $ rheLog (handlerEnv hd) a b c (toLogStr d) rheLog (handlerEnv hd) a b c (toLogStr d)
instance MonadIO m => MonadLoggerIO (HandlerT site m) where instance MonadLoggerIO (HandlerFor site) where
askLoggerIO = HandlerT $ \hd -> return (rheLog (handlerEnv hd)) askLoggerIO = HandlerFor $ \hd -> return (rheLog (handlerEnv hd))
instance Monoid (UniqueList x) where instance Monoid (UniqueList x) where
mempty = UniqueList id mempty = UniqueList id

5
yesod-core/Yesod/Core/Unsafe.hs
View File

@ -19,7 +19,10 @@ import Control.Monad.IO.Class (MonadIO)
-- --
-- > unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger -- > unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger
fakeHandlerGetLogger :: (Yesod site, MonadIO m) fakeHandlerGetLogger :: (Yesod site, MonadIO m)
=> (site -> Logger) -> site -> HandlerT site IO a -> m a => (site -> Logger)
-> site
-> HandlerFor site a
-> m a
fakeHandlerGetLogger getLogger app f = fakeHandlerGetLogger getLogger app f =
runFakeHandler mempty getLogger app f runFakeHandler mempty getLogger app f
>>= either (error . ("runFakeHandler issue: " `mappend`) . show) >>= either (error . ("runFakeHandler issue: " `mappend`) . show)

56
yesod-core/Yesod/Core/Widget.hs
View File

@ -14,6 +14,7 @@
module Yesod.Core.Widget module Yesod.Core.Widget
( -- * Datatype ( -- * Datatype
WidgetT WidgetT
, WidgetFor
, PageContent (..) , PageContent (..)
-- * Special Hamlet quasiquoter/TH for Widgets -- * Special Hamlet quasiquoter/TH for Widgets
, whamlet , whamlet
@ -43,7 +44,6 @@ module Yesod.Core.Widget
, addScriptRemoteAttrs , addScriptRemoteAttrs
, addScriptEither , addScriptEither
-- * Subsites -- * Subsites
, widgetToParentWidget
, handlerToWidget , handlerToWidget
-- * Internal -- * Internal
, whamletFileWithSettings , whamletFileWithSettings
@ -60,7 +60,6 @@ import Yesod.Core.Handler (getMessageRender, getUrlRenderParams)
#if __GLASGOW_HASKELL__ < 710 #if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
#endif #endif
import Control.Monad.IO.Class (MonadIO, liftIO)
import Text.Shakespeare.I18N (RenderMessage) import Text.Shakespeare.I18N (RenderMessage)
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Map as Map import qualified Data.Map as Map
@ -72,11 +71,13 @@ import Data.Text.Lazy.Builder (fromLazyText)
import Text.Blaze.Html (toHtml, preEscapedToMarkup) import Text.Blaze.Html (toHtml, preEscapedToMarkup)
import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TB import qualified Data.Text.Lazy.Builder as TB
import Data.IORef
import Yesod.Core.Types import Yesod.Core.Types
import Yesod.Core.Class.Handler import Yesod.Core.Class.Handler
type WidgetT site (m :: * -> *) = WidgetFor site
{-# DEPRECATED WidgetT "Use WidgetFor directly" #-}
preEscapedLazyText :: TL.Text -> Html preEscapedLazyText :: TL.Text -> Html
preEscapedLazyText = preEscapedToMarkup preEscapedLazyText = preEscapedToMarkup
@ -97,8 +98,8 @@ instance render ~ RY site => ToWidget site (render -> Javascript) where
toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Just x) mempty toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Just x) mempty
instance ToWidget site Javascript where instance ToWidget site Javascript where
toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Just $ const x) mempty toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Just $ const x) mempty
instance (site' ~ site, IO ~ m, a ~ ()) => ToWidget site' (WidgetT site m a) where instance (site' ~ site, a ~ ()) => ToWidget site' (WidgetFor site a) where
toWidget = liftWidgetT toWidget = liftWidget
instance ToWidget site Html where instance ToWidget site Html where
toWidget = toWidget . const toWidget = toWidget . const
-- | @since 1.4.28 -- | @since 1.4.28
@ -268,49 +269,10 @@ ihamletToHtml ih = do
return $ ih (toHtml . mrender) urender return $ ih (toHtml . mrender) urender
tell :: MonadWidget m => GWData (Route (HandlerSite m)) -> m () tell :: MonadWidget m => GWData (Route (HandlerSite m)) -> m ()
tell = liftWidgetT . tellWidget tell = liftWidget . tellWidget
toUnique :: x -> UniqueList x toUnique :: x -> UniqueList x
toUnique = UniqueList . (:) toUnique = UniqueList . (:)
handlerToWidget :: Monad m => HandlerT site m a -> WidgetT site m a handlerToWidget :: HandlerFor site a -> WidgetFor site a
handlerToWidget (HandlerT f) = WidgetT $ const f handlerToWidget (HandlerFor f) = WidgetFor $ f . wdHandler
widgetToParentWidget :: MonadIO m
=> WidgetT child IO a
-> HandlerT child (HandlerT parent m) (WidgetT parent m a)
widgetToParentWidget (WidgetT f) = HandlerT $ \hdChild -> do
return $ WidgetT $ \ref _hdParent -> liftIO $ do
tmp <- newIORef mempty
a <- f tmp hdChild { handlerToParent = const () }
gwd <- readIORef tmp
modifyIORef' ref (<> liftGWD (handlerToParent hdChild) gwd)
return a
liftGWD :: (child -> parent) -> GWData child -> GWData parent
liftGWD tp gwd = GWData
{ gwdBody = fixBody $ gwdBody gwd
, gwdTitle = gwdTitle gwd
, gwdScripts = fixUnique fixScript $ gwdScripts gwd
, gwdStylesheets = fixUnique fixStyle $ gwdStylesheets gwd
, gwdCss = fixCss <$> gwdCss gwd
, gwdJavascript = fixJS <$> gwdJavascript gwd
, gwdHead = fixHead $ gwdHead gwd
}
where
fixRender f route = f (tp route)
fixBody (Body h) = Body $ h . fixRender
fixHead (Head h) = Head $ h . fixRender
fixUnique go (UniqueList f) = UniqueList (map go (f []) ++)
fixScript (Script loc attrs) = Script (fixLoc loc) attrs
fixStyle (Stylesheet loc attrs) = Stylesheet (fixLoc loc) attrs
fixLoc (Local url) = Local $ tp url
fixLoc (Remote t) = Remote t
fixCss f = f . fixRender
fixJS f = f . fixRender

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

@ -1,5 +1,6 @@
{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-} {-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances, ViewPatterns #-} {-# LANGUAGE FlexibleInstances, ViewPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-} -- the module name is a lie!!! {-# LANGUAGE OverloadedStrings #-} -- the module name is a lie!!!
module YesodCoreTest.NoOverloadedStrings module YesodCoreTest.NoOverloadedStrings
( noOverloadedTest ( noOverloadedTest
@ -20,19 +21,19 @@ import qualified Data.ByteString.Lazy.Char8 as L8
getSubsite :: a -> Subsite getSubsite :: a -> Subsite
getSubsite _ = Subsite $(mkYesodSubDispatch resourcesSubsite) getSubsite _ = Subsite $(mkYesodSubDispatch resourcesSubsite)
getBarR :: Monad m => m T.Text getBarR :: MonadSubHandler m => m T.Text
getBarR = return $ T.pack "BarR" getBarR = return $ T.pack "BarR"
getBazR :: Yesod master => HandlerT Subsite (HandlerT master IO) Html getBazR :: (MonadSubHandler m, Yesod (HandlerSite m)) => m Html
getBazR = lift $ defaultLayout [whamlet|Used Default Layout|] getBazR = liftHandler $ defaultLayout [whamlet|Used Default Layout|]
getBinR :: Yesod master => HandlerT Subsite (HandlerT master IO) Html getBinR :: (MonadSubHandler m, Yesod (HandlerSite m), SubHandlerSite m ~ Subsite) => m Html
getBinR = do getBinR = do
widget <- widgetToParentWidget [whamlet| toParentRoute <- getToParentRoute
liftHandler $ defaultLayout [whamlet|
<p>Used defaultLayoutT <p>Used defaultLayoutT
<a href=@{BazR}>Baz <a href=@{toParentRoute BazR}>Baz
|] |]
lift $ defaultLayout widget
getOnePiecesR :: Monad m => Int -> m () getOnePiecesR :: Monad m => Int -> m ()
getOnePiecesR _ = return () getOnePiecesR _ = return ()

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

@ -10,7 +10,7 @@ module YesodCoreTest.NoOverloadedStringsSub where
import Yesod.Core import Yesod.Core
import Yesod.Core.Types import Yesod.Core.Types
data Subsite = Subsite (forall master. Yesod master => YesodSubRunnerEnv Subsite master (HandlerT master IO) -> Application) data Subsite = Subsite (forall master. Yesod master => YesodSubRunnerEnv Subsite master (HandlerFor master) -> Application)
mkYesodSubData "Subsite" [parseRoutes| mkYesodSubData "Subsite" [parseRoutes|
/bar BarR GET /bar BarR GET
@ -21,7 +21,7 @@ mkYesodSubData "Subsite" [parseRoutes|
/has-three-pieces/#Int/#Int/#Int ThreePiecesR GET /has-three-pieces/#Int/#Int/#Int ThreePiecesR GET
|] |]
instance Yesod master => YesodSubDispatch Subsite (HandlerT master IO) where instance Yesod master => YesodSubDispatch Subsite (HandlerFor master) where
yesodSubDispatch ysre = yesodSubDispatch ysre =
f ysre f ysre
where where