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
* 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
, ScriptLoadPosition (..)
, BottomOfHeadAsync
-- * Subsites
-- * Generalizing type classes
, MonadHandler (..)
, MonadWidget (..)
, getRouteToParent
, defaultLayoutSub
-- * Approot
, guessApproot
, guessApprootOr
, getApprootText
-- * Subsites
, MonadSubHandler (..)
-- * Misc
, yesodVersion
, yesodRender
@ -185,14 +185,6 @@ maybeAuthorized r isWrite = do
x <- isAuthorized r isWrite
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 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
-- | Returns the title and the parent resource, if available. If you return
-- 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,
-- 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
x <- getCurrentRoute
case x of

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

@ -6,13 +6,13 @@
{-# LANGUAGE FlexibleContexts #-}
module Yesod.Core.Class.Dispatch where
import Yesod.Routes.Class
import qualified Network.Wai as W
import Yesod.Core.Types
import Yesod.Core.Content
import Yesod.Core.Handler (sendWaiApplication, stripHandlerT)
import Yesod.Core.Class.Yesod
import Yesod.Core.Content (ToTypedContent (..))
import Yesod.Core.Handler (sendWaiApplication, getYesod, getCurrentRoute)
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
-- mkYesod function. You should never need to deal with it directly.
@ -28,24 +28,63 @@ instance YesodSubDispatch WaiSubsite master where
where
WaiSubsite app = ysreGetSub $ yreSite ysreParentEnv
instance YesodSubDispatch WaiSubsiteWithAuth (HandlerT master IO) where
instance MonadHandler m => YesodSubDispatch WaiSubsiteWithAuth m where
yesodSubDispatch YesodSubRunnerEnv {..} req =
ysreParentRunner base ysreParentEnv (fmap ysreToParentRoute route) req
ysreParentRunner handlert ysreParentEnv (fmap ysreToParentRoute route) req
where
base = stripHandlerT handlert ysreGetSub ysreToParentRoute route
route = Just $ WaiSubsiteWithAuthRoute (W.pathInfo req) []
WaiSubsiteWithAuth set = ysreGetSub $ yreSite $ ysreParentEnv
handlert = sendWaiApplication $ set
handlert = sendWaiApplication set
-- | A helper function for creating YesodSubDispatch instances, used by the
-- internal generated code. This function has been exported since 1.4.11.
-- It promotes a subsite handler to a wai application.
subHelper :: Monad m -- NOTE: This is incredibly similar in type signature to yesodRunner, should probably be pointed out/explained.
=> HandlerT child (HandlerT parent m) TypedContent
-> YesodSubRunnerEnv child parent (HandlerT parent m)
-> Maybe (Route child)
-> W.Application
subHelper handlert YesodSubRunnerEnv {..} route =
ysreParentRunner base ysreParentEnv (fmap ysreToParentRoute route)
type SubHandler child parent a = ReaderT (SubsiteData child parent) (HandlerFor parent) a
data SubsiteData child parent = SubsiteData
{ sdToParentRoute :: !(Route child -> Route parent)
, sdCurrentRoute :: !(Maybe (Route child))
, sdSubsiteData :: !child
}
class MonadHandler m => MonadSubHandler m where
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
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
( MonadHandler (..)
, MonadWidget (..)
, liftHandlerT
, liftWidgetT
) where
import Yesod.Core.Types
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Resource (MonadResource, MonadResourceBase)
import Control.Monad.Trans.Resource (MonadResource)
import Control.Monad.Trans.Class (lift)
#if __GLASGOW_HASKELL__ < 710
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.Writer.Strict as Strict ( WriterT )
-- FIXME should we just use MonadReader instances instead?
class MonadResource m => MonadHandler m where
type HandlerSite m
liftHandlerT :: HandlerT (HandlerSite m) IO a -> m a
liftHandler :: HandlerFor (HandlerSite m) a -> m a
replaceToParent :: HandlerData site route -> HandlerData site ()
replaceToParent hd = hd { handlerToParent = const () }
liftHandlerT :: MonadHandler m => HandlerFor (HandlerSite m) a -> m a
liftHandlerT = liftHandler
{-# DEPRECATED liftHandlerT "Use liftHandler instead" #-}
instance MonadResourceBase m => MonadHandler (HandlerT site m) where
type HandlerSite (HandlerT site m) = site
liftHandlerT (HandlerT f) = HandlerT $ liftIO . f . replaceToParent
{-# RULES "liftHandlerT (HandlerT site IO)" liftHandlerT = id #-}
instance MonadHandler (HandlerFor site) where
type HandlerSite (HandlerFor site) = site
liftHandler = id
{-# INLINE liftHandler #-}
instance MonadResourceBase m => MonadHandler (WidgetT site m) where
type HandlerSite (WidgetT site m) = site
liftHandlerT (HandlerT f) = WidgetT $ \_ref env -> liftIO $ f $ replaceToParent env
{-# RULES "liftHandlerT (WidgetT site IO)" forall f. liftHandlerT (HandlerT f) = WidgetT $ const f #-}
instance MonadHandler (WidgetFor site) where
type HandlerSite (WidgetFor site) = site
liftHandler (HandlerFor f) = WidgetFor $ f . wdHandler
{-# INLINE liftHandler #-}
#define GO(T) instance 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; 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; liftHandler = lift . liftHandler
GO(IdentityT)
GO(ListT)
GO(MaybeT)
@ -70,12 +73,17 @@ GO(ConduitM i o)
#undef GOX
class MonadHandler m => MonadWidget m where
liftWidgetT :: WidgetT (HandlerSite m) IO a -> m a
instance MonadResourceBase m => MonadWidget (WidgetT site m) where
liftWidgetT (WidgetT f) = WidgetT $ \ref env -> liftIO $ f ref $ replaceToParent env
liftWidget :: WidgetFor (HandlerSite m) a -> m a
instance MonadWidget (WidgetFor site) where
liftWidget = id
{-# INLINE liftWidget #-}
#define GO(T) instance MonadWidget m => MonadWidget (T m) where liftWidgetT = lift . liftWidgetT
#define GOX(X, T) instance (X, MonadWidget m) => MonadWidget (T m) where liftWidgetT = lift . liftWidgetT
liftWidgetT :: MonadWidget m => WidgetFor (HandlerSite m) a -> m a
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(ListT)
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.Internal.Session
import Yesod.Core.Widget
import Control.Monad.Trans.Class (lift)
import Data.CaseInsensitive (CI)
import qualified Network.Wai.Request
import Data.IORef
@ -83,11 +82,11 @@ class RenderRoute site => Yesod site where
-- | Output error response pages.
--
-- Default value: 'defaultErrorHandler'.
errorHandler :: ErrorResponse -> HandlerT site IO TypedContent
errorHandler :: ErrorResponse -> HandlerFor site TypedContent
errorHandler = defaultErrorHandler
-- | 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
p <- widgetToPageContent w
msgs <- getMessages
@ -139,7 +138,7 @@ class RenderRoute site => Yesod site where
-- If authentication is required, return 'AuthenticationRequired'.
isAuthorized :: Route site
-> Bool -- ^ is this a write request?
-> HandlerT site IO AuthResult
-> HandlerFor site AuthResult
isAuthorized _ _ = return Authorized
-- | 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
-- 'isAuthorized'.
isWriteRequest :: Route site -> HandlerT site IO Bool
isWriteRequest :: Route site -> HandlerFor site Bool
isWriteRequest _ = do
wai <- waiRequest
return $ W.requestMethod wai `notElem`
@ -215,7 +214,7 @@ class RenderRoute site => Yesod site where
addStaticContent :: Text -- ^ filename extension
-> Text -- ^ mime-type
-> 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
-- | Maximum allowed length of the request body, in bytes.
@ -304,7 +303,7 @@ class RenderRoute site => Yesod site where
-- Default: the 'defaultYesodMiddleware' function.
--
-- 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
-- | 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.
--
-- @since 1.4.30
defaultMessageWidget :: Html -> HtmlUrl (Route site) -> WidgetT site IO ()
defaultMessageWidget :: Html -> HtmlUrl (Route site) -> WidgetFor site ()
defaultMessageWidget title body = do
setTitle title
toWidget
@ -384,7 +383,7 @@ defaultShouldLogIO a b = return $ defaultShouldLog a b
-- \"Vary: Accept, Accept-Language\" and performs authorization checks.
--
-- 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
addHeader "Vary" "Accept, Accept-Language"
authorizationCheck
@ -444,8 +443,8 @@ sameSiteSession s = (fmap . fmap) secureSessionCookies
--
-- Since 1.4.7
sslOnlyMiddleware :: Int -- ^ minutes
-> HandlerT site IO res
-> HandlerT site IO res
-> HandlerFor site res
-> HandlerFor site res
sslOnlyMiddleware timeout handler = do
addHeader "Strict-Transport-Security"
$ T.pack $ concat [ "max-age="
@ -458,7 +457,7 @@ sslOnlyMiddleware timeout handler = do
-- 'isWriteRequest'.
--
-- Since 1.2.0
authorizationCheck :: Yesod site => HandlerT site IO ()
authorizationCheck :: Yesod site => HandlerFor site ()
authorizationCheck = getCurrentRoute >>= maybe (return ()) checkUrl
where
checkUrl url = do
@ -482,7 +481,7 @@ authorizationCheck = getCurrentRoute >>= maybe (return ()) checkUrl
-- | Calls 'csrfCheckMiddleware' with 'isWriteRequest', 'defaultCsrfHeaderName', and 'defaultCsrfParamName' as parameters.
--
-- 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 =
csrfCheckMiddleware
handler
@ -496,11 +495,11 @@ defaultCsrfCheckMiddleware handler =
-- For details, see the "AJAX CSRF protection" section of "Yesod.Core.Handler".
--
-- Since 1.4.14
csrfCheckMiddleware :: HandlerT site IO res
-> HandlerT site IO Bool -- ^ Whether or not to perform the CSRF check.
csrfCheckMiddleware :: HandlerFor site res
-> HandlerFor site Bool -- ^ Whether or not to perform the CSRF check.
-> CI S8.ByteString -- ^ The header 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
shouldCheck <- shouldCheckFn
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.
--
-- Since 1.4.14
defaultCsrfSetCookieMiddleware :: HandlerT site IO res -> HandlerT site IO res
defaultCsrfSetCookieMiddleware :: HandlerFor site res -> HandlerFor site res
defaultCsrfSetCookieMiddleware handler = setCsrfCookie >> handler
-- | 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 @/@.
--
-- 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
-- | Calls 'defaultCsrfSetCookieMiddleware' and 'defaultCsrfCheckMiddleware'.
@ -541,23 +540,26 @@ csrfSetCookieMiddleware handler cookie = setCsrfCookieWithCookie cookie >> handl
-- @
--
-- 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
-- | Convert a widget to a 'PageContent'.
widgetToPageContent :: Yesod site
=> WidgetT site IO ()
-> HandlerT site IO (PageContent (Route site))
widgetToPageContent w = do
master <- getYesod
hd <- HandlerT return
ref <- lift $ newIORef mempty
lift $ unWidgetT w ref hd
GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head') <- lift $ readIORef ref
let title = maybe mempty unTitle mTitle
scripts = runUniqueList scripts'
stylesheets = runUniqueList stylesheets'
=> WidgetFor site ()
-> HandlerFor site (PageContent (Route site))
widgetToPageContent w = HandlerFor $ \hd -> do
master <- unHandlerFor getYesod hd
ref <- newIORef mempty
unWidgetFor w WidgetData
{ wdRef = ref
, wdHandler = hd
}
GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head') <- readIORef ref
let title = maybe mempty unTitle mTitle
scripts = runUniqueList scripts'
stylesheets = runUniqueList stylesheets'
flip unHandlerFor hd $ do
render <- getUrlRenderParams
let renderLoc x =
case x of
@ -645,7 +647,7 @@ widgetToPageContent w = do
runUniqueList (UniqueList x) = nub $ x []
-- | 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
provideRep $ defaultLayout $ do
r <- waiRequest

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

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

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

@ -27,6 +27,7 @@
module Yesod.Core.Handler
( -- * Handler monad
HandlerT
, HandlerFor
-- ** Read information from handler
, getYesod
, getsYesod
@ -161,7 +162,6 @@ module Yesod.Core.Handler
-- * Per-request caching
, cached
, cachedBy
, stripHandlerT
-- * AJAX CSRF protection
-- $ajaxCSRFOverview
@ -254,14 +254,17 @@ import qualified Data.Foldable as Fold
import Data.Default
import Control.Monad.Logger (MonadLogger, logWarnS)
type HandlerT site (m :: * -> *) = HandlerFor site
{-# DEPRECATED HandlerT "Use HandlerFor directly" #-}
get :: MonadHandler m => m GHState
get = liftHandlerT $ HandlerT $ I.readIORef . handlerState
get = liftHandler $ HandlerFor $ I.readIORef . handlerState
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 f = liftHandlerT $ HandlerT $ flip I.modifyIORef f . handlerState
modify f = liftHandler $ HandlerFor $ flip I.modifyIORef f . handlerState
tell :: MonadHandler m => Endo [Header] -> m ()
tell hs = modify $ \g -> g { ghsHeaders = ghsHeaders g `mappend` hs }
@ -273,14 +276,14 @@ hcError :: MonadHandler m => ErrorResponse -> m a
hcError = handlerError . HCError
getRequest :: MonadHandler m => m YesodRequest
getRequest = liftHandlerT $ HandlerT $ return . handlerRequest
getRequest = liftHandler $ HandlerFor $ return . handlerRequest
runRequestBody :: MonadHandler m => m RequestBodyContents
runRequestBody = do
HandlerData
{ handlerEnv = RunHandlerEnv {..}
, handlerRequest = req
} <- liftHandlerT $ HandlerT return
} <- liftHandler $ HandlerFor return
let len = W.requestBodyLength $ reqWaiRequest req
upload = rheUpload len
x <- get
@ -320,7 +323,7 @@ rbHelper' backend mkFI req =
go = decodeUtf8With lenientDecode
askHandlerEnv :: MonadHandler m => m (RunHandlerEnv (HandlerSite m))
askHandlerEnv = liftHandlerT $ HandlerT $ return . handlerEnv
askHandlerEnv = liftHandler $ HandlerFor $ return . handlerEnv
-- | Get the master site application argument.
getYesod :: MonadHandler m => m (HandlerSite m)
@ -396,9 +399,9 @@ getCurrentRoute = rheRoute <$> askHandlerEnv
-- This allows the inner 'GHandler' to outlive the outer
-- 'GHandler' (e.g., on the @forkIO@ example above, a response
-- 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 =
HandlerT $ \oldHandlerData -> do
HandlerFor $ \oldHandlerData -> do
-- Take just the bits we need from oldHandlerData.
let newReq = oldReq { reqWaiRequest = newWaiReq }
where
@ -420,7 +423,7 @@ handlerToIO =
liftIO $ evaluate (newReq `seq` oldEnv `seq` newState `seq` ())
-- Return GHandler running function.
return $ \(HandlerT f) ->
return $ \(HandlerFor f) ->
liftIO $
runResourceT $ withInternalState $ \resState -> do
-- The state IORef needs to be created here, otherwise it
@ -431,7 +434,6 @@ handlerToIO =
{ handlerRequest = newReq
, handlerEnv = oldEnv
, handlerState = newStateIORef
, handlerToParent = const ()
, handlerResource = resState
}
liftIO (f newHandlerData)
@ -442,9 +444,9 @@ handlerToIO =
-- for correctness and efficiency
--
-- @since 1.2.8
forkHandler :: (SomeException -> HandlerT site IO ()) -- ^ error handler
-> HandlerT site IO ()
-> HandlerT site IO ()
forkHandler :: (SomeException -> HandlerFor site ()) -- ^ error handler
-> HandlerFor site ()
-> HandlerFor site ()
forkHandler onErr handler = do
yesRunner <- handlerToIO
void $ liftResourceT $ resourceForkIO $ yesRunner $ handle onErr handler
@ -1370,14 +1372,14 @@ respond ct = return . TypedContent ct . toContent
--
-- @since 1.2.0
respondSource :: ContentType
-> Source (HandlerT site IO) (Flush Builder)
-> HandlerT site IO TypedContent
respondSource ctype src = HandlerT $ \hd ->
-> Source (HandlerFor site) (Flush Builder)
-> HandlerFor site TypedContent
respondSource ctype src = HandlerFor $ \hd ->
-- Note that this implementation relies on the fact that the ResourceT
-- environment provided by the server is the same one used in HandlerT.
-- This is a safe assumption assuming the HandlerT is run correctly.
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
-- on most datatypes, such as @ByteString@ and @Html@.
@ -1423,25 +1425,6 @@ sendChunkLazyText = sendChunk
sendChunkHtml :: Monad m => Html -> Producer m (Flush Builder)
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
-- 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.

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

@ -46,8 +46,8 @@ instance Monoid LiteApp where
mempty = LiteApp $ \_ _ -> Nothing
mappend (LiteApp x) (LiteApp y) = LiteApp $ \m ps -> x m ps <|> y m ps
type LiteHandler = HandlerT LiteApp IO
type LiteWidget = WidgetT LiteApp IO
type LiteHandler = HandlerFor LiteApp
type LiteWidget = WidgetFor LiteApp
liteApp :: Writer LiteApp () -> LiteApp
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@.
basicRunHandler :: ToTypedContent c
=> RunHandlerEnv site
-> HandlerT site IO c
-> HandlerFor site c
-> YesodRequest
-> InternalState
-> IO (GHState, HandlerContents)
@ -96,7 +96,7 @@ basicRunHandler rhe handler yreq resState = do
-- converting them into a @HandlerContents@
contents' <- catchSync
(do
res <- unHandlerT handler (hd istate)
res <- unHandlerFor handler (hd istate)
tc <- evaluate (toTypedContent res)
-- Success! Wrap it up in an @HCContent@
return (HCContent defaultStatus tc))
@ -121,7 +121,6 @@ basicRunHandler rhe handler yreq resState = do
{ handlerRequest = yreq
, handlerEnv = rhe
, handlerState = istate
, handlerToParent = const ()
, handlerResource = resState
}
@ -208,7 +207,7 @@ evalFallback contents val = catchSync
-- 'HandlerT' into an 'Application'. Should not be needed by users.
runHandler :: ToTypedContent c
=> RunHandlerEnv site
-> HandlerT site IO c
-> HandlerFor site c
-> YesodApp
runHandler rhe@RunHandlerEnv {..} handler yreq = withInternalState $ \resState -> do
-- Get the raw state and original contents
@ -263,7 +262,7 @@ runFakeHandler :: (Yesod site, MonadIO m) =>
SessionMap
-> (site -> Logger)
-> site
-> HandlerT site IO a
-> HandlerFor site a
-> m (Either ErrorResponse a)
runFakeHandler fakeSessionMap logger site handler = liftIO $ do
ret <- I.newIORef (Left $ InternalError "runFakeHandler: no result")
@ -322,7 +321,7 @@ runFakeHandler fakeSessionMap logger site handler = liftIO $ do
I.readIORef ret
yesodRunner :: (ToTypedContent res, Yesod site)
=> HandlerT site IO res
=> HandlerFor site res
-> YesodRunnerEnv site
-> Maybe (Route site)
-> 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.Parse
import Yesod.Core.Types
import Yesod.Core.Content
import Yesod.Core.Class.Dispatch
import Yesod.Core.Internal.Run
@ -102,12 +101,12 @@ mkYesodDispatch :: String -> [ResourceTree String] -> Q [Dec]
mkYesodDispatch name = fmap snd . mkYesodGeneral name [] False return
-- | 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 =
[ TySynD (mkName "Handler") (fmap PlainTV vs)
$ ConT ''HandlerT `AppT` site `AppT` ConT ''IO
$ ConT ''HandlerFor `AppT` site
, 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
@ -242,7 +241,7 @@ mkDispatchInstance master cxt f res = do
mkYesodSubDispatch :: [ResourceTree a] -> Q Exp
mkYesodSubDispatch res = do
clause' <- mkDispatchClause (mkMDS return [|subHelper . fmap toTypedContent|]) res
clause' <- mkDispatchClause (mkMDS return [|subHelper|]) res
inner <- newName "inner"
let innerFun = FunD inner [clause']
helper <- newName "helper"

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

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

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

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

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

@ -14,6 +14,7 @@
module Yesod.Core.Widget
( -- * Datatype
WidgetT
, WidgetFor
, PageContent (..)
-- * Special Hamlet quasiquoter/TH for Widgets
, whamlet
@ -43,7 +44,6 @@ module Yesod.Core.Widget
, addScriptRemoteAttrs
, addScriptEither
-- * Subsites
, widgetToParentWidget
, handlerToWidget
-- * Internal
, whamletFileWithSettings
@ -60,7 +60,6 @@ import Yesod.Core.Handler (getMessageRender, getUrlRenderParams)
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((<$>))
#endif
import Control.Monad.IO.Class (MonadIO, liftIO)
import Text.Shakespeare.I18N (RenderMessage)
import Data.Text (Text)
import qualified Data.Map as Map
@ -72,11 +71,13 @@ import Data.Text.Lazy.Builder (fromLazyText)
import Text.Blaze.Html (toHtml, preEscapedToMarkup)
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TB
import Data.IORef
import Yesod.Core.Types
import Yesod.Core.Class.Handler
type WidgetT site (m :: * -> *) = WidgetFor site
{-# DEPRECATED WidgetT "Use WidgetFor directly" #-}
preEscapedLazyText :: TL.Text -> Html
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
instance ToWidget site Javascript where
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
toWidget = liftWidgetT
instance (site' ~ site, a ~ ()) => ToWidget site' (WidgetFor site a) where
toWidget = liftWidget
instance ToWidget site Html where
toWidget = toWidget . const
-- | @since 1.4.28
@ -268,49 +269,10 @@ ihamletToHtml ih = do
return $ ih (toHtml . mrender) urender
tell :: MonadWidget m => GWData (Route (HandlerSite m)) -> m ()
tell = liftWidgetT . tellWidget
tell = liftWidget . tellWidget
toUnique :: x -> UniqueList x
toUnique = UniqueList . (:)
handlerToWidget :: Monad m => HandlerT site m a -> WidgetT site m a
handlerToWidget (HandlerT f) = WidgetT $ const f
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
handlerToWidget :: HandlerFor site a -> WidgetFor site a
handlerToWidget (HandlerFor f) = WidgetFor $ f . wdHandler

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

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