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

Simplified GHandler/GWidget

Browse Source
This commit is contained in:
Michael Snoyman 2013-03-13 10:59:10 +02:00
parent fc6551c650
commit 4bdd01ef58
14 changed files with 233 additions and 320 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -49,7 +49,7 @@ module Yesod.Core
, BottomOfHeadAsync
-- * Subsites
, defaultLayoutT
, MonadHandlerBase (..)
, MonadHandler (..)
-- * Misc
, yesodVersion
, yesodRender
@ -92,8 +92,8 @@ import Data.Version (showVersion)
import Yesod.Routes.Class (RenderRoute (..))
-- | Return an 'Unauthorized' value, with the given i18n message.
unauthorizedI :: RenderMessage master msg => msg -> GHandler sub master AuthResult
unauthorizedI msg =do
unauthorizedI :: RenderMessage site msg => msg -> GHandler site AuthResult
unauthorizedI msg = do
mr <- getMessageRender
return $ Unauthorized $ mr msg
@ -104,37 +104,19 @@ yesodVersion = showVersion Paths_yesod_core.version
--
-- Built on top of 'isAuthorized'. This is useful for building page that only
-- contain links to pages the user is allowed to see.
maybeAuthorized :: Yesod a
=> Route a
maybeAuthorized :: Yesod site
=> Route site
-> Bool -- ^ is this a write request?
-> GHandler s a (Maybe (Route a))
-> GHandler site (Maybe (Route site))
maybeAuthorized r isWrite = do
x <- isAuthorized r isWrite
return $ if x == Authorized then Just r else Nothing
class (MonadResource m, HandlerState m, Yesod (HandlerBase m)) => MonadHandlerBase m where
type HandlerBase m
type HandlerSite m
liftHandler :: GHandler (HandlerBase m) (HandlerBase m) a -> m a
askHandlerData :: m (HandlerData (HandlerSite m) (HandlerSite m))
instance Yesod master => MonadHandlerBase (GHandler master master) where
type HandlerBase (GHandler master master) = master
type HandlerSite (GHandler master master) = master
liftHandler = id
askHandlerData = GHandler return
instance MonadHandlerBase m => MonadHandlerBase (HandlerT sub m) where
type HandlerBase (HandlerT sub m) = HandlerBase m
type HandlerSite (HandlerT sub m) = sub
liftHandler = lift . liftHandler
askHandlerData = HandlerT return
defaultLayoutT :: ( HandlerState m
, HandlerSite m ~ sub
, Yesod (HandlerBase m)
, MonadHandlerBase m
, MonadResource m
defaultLayoutT :: ( HandlerSite m ~ sub
, Yesod (HandlerMaster m)
, MonadHandler m
)
=> GWidget sub sub ()
=> GWidget sub ()
-> m RepHtml
defaultLayoutT (GWidget (GHandler f)) = do
hd <- askHandlerData

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

@ -8,14 +8,14 @@ import Data.Text (Text)
-- | A type-safe, concise method of creating breadcrumbs for pages. For each
-- resource, you declare the title of the page and the parent resource (if
-- present).
class YesodBreadcrumbs y where
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 y -> GHandler sub y (Text , Maybe (Route y))
breadcrumb :: Route site -> GHandler 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 y => GHandler sub y (Text, [(Route y, Text)])
breadcrumbs :: YesodBreadcrumbs site => GHandler site (Text, [(Route site, Text)])
breadcrumbs = do
x <- getCurrentRoute
case x of

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

@ -18,56 +18,36 @@ import Control.Monad.Trans.Control (MonadBaseControl)
-- | This class is automatically instantiated when you use the template haskell
-- mkYesod function. You should never need to deal with it directly.
class YesodDispatch sub master where
yesodDispatch
:: Yesod master
=> YesodRunnerEnv sub master
-> W.Application
instance YesodDispatch WaiSubsite master where
yesodDispatch YesodRunnerEnv { yreSub = WaiSubsite app } req =
app req
class Yesod site => YesodDispatch site where
yesodDispatch :: YesodRunnerEnv site -> W.Application
class YesodSubDispatch sub m where
yesodSubDispatch
:: (HandlerError m, HandlerState m, master ~ HandlerMaster m, Yesod master, MonadBaseControl IO m)
:: (MonadHandler m, master ~ HandlerMaster m, Yesod master)
=> (m TypedContent
-> YesodRunnerEnv master master
-> YesodRunnerEnv master
-> Maybe (Route master)
-> W.Application)
-> (master -> sub)
-> (Route sub -> Route master)
-> YesodRunnerEnv master master
-> YesodRunnerEnv master
-> W.Application
instance YesodSubDispatch WaiSubsite master where
yesodSubDispatch _ toSub _ YesodRunnerEnv { yreMaster = master } req =
yesodSubDispatch _ toSub _ YesodRunnerEnv { yreSite = site } req =
app req
where
WaiSubsite app = toSub master
WaiSubsite app = toSub site
{-
subHelper :: Yesod master => (YesodRunnerEnv sub master -> W.Application)
-> (forall res. ToTypedContent res
=> m res
-> YesodRunnerEnv master master
-> Maybe (Route master)
-> W.Application)
-> (master -> sub)
-> (Route sub -> Route master)
-> W.Application
subHelper runBase getSub toMaster = error "subHelper"
-}
subHelper :: (HandlerMaster m ~ master, HandlerState m, MonadBaseControl IO m)
subHelper :: (HandlerSite m ~ master, MonadHandler m)
=> (m TypedContent
-> YesodRunnerEnv master master
-> YesodRunnerEnv master
-> Maybe (Route master)
-> W.Application)
-> (master -> sub)
-> (Route sub -> Route master)
-> HandlerT sub m TypedContent
-> YesodRunnerEnv master master
-> YesodRunnerEnv master
-> Maybe (Route sub)
-> W.Application
subHelper parentRunner getSub toMaster handlert env route =

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

@ -5,35 +5,38 @@
module Yesod.Core.Class.Handler where
import Yesod.Core.Types
import Yesod.Core.Types.Orphan ()
import Yesod.Core.Class.MonadLift (lift)
import Control.Monad.Trans.Class (MonadTrans)
import Control.Monad.Trans.Resource
import Control.Monad.Trans.Control
import Data.IORef.Lifted (atomicModifyIORef)
import Control.Exception.Lifted (throwIO)
class Monad m => HandlerReader m where
type HandlerSub m
type HandlerSite m
type HandlerMaster m
askYesodRequest :: m YesodRequest
askHandlerEnv :: m (RunHandlerEnv (HandlerSub m) (HandlerMaster m))
askHandlerEnv :: m (RunHandlerEnv (HandlerSite m))
instance HandlerReader (GHandler sub master) where
type HandlerSub (GHandler sub master) = sub
type HandlerMaster (GHandler sub master) = master
instance HandlerReader (GHandler site) where
type HandlerSite (GHandler site) = site
type HandlerMaster (GHandler site) = site
askYesodRequest = GHandler $ return . handlerRequest
askHandlerEnv = GHandler $ return . handlerEnv
instance HandlerReader (GWidget sub master) where
type HandlerSub (GWidget sub master) = sub
type HandlerMaster (GWidget sub master) = master
instance HandlerReader m => HandlerReader (HandlerT site m) where
type HandlerSite (HandlerT site m) = site
type HandlerMaster (HandlerT site m) = HandlerMaster m
askYesodRequest = lift askYesodRequest
askHandlerEnv = lift askHandlerEnv
askYesodRequest = HandlerT $ return . handlerRequest
askHandlerEnv = HandlerT $ return . handlerEnv
instance (MonadTrans t, HandlerReader m, Monad (t m)) => HandlerReader (t m) where
type HandlerSub (t m) = HandlerSub m
type HandlerMaster (t m) = HandlerMaster m
instance HandlerReader (GWidget site) where
type HandlerSite (GWidget site) = site
type HandlerMaster (GWidget site) = site
askYesodRequest = lift askYesodRequest
askHandlerEnv = lift askHandlerEnv
@ -47,26 +50,26 @@ class HandlerReader m => HandlerState m where
putGHState :: GHState -> m ()
putGHState s = stateGHState $ const ((), s)
instance HandlerState (GHandler sub master) where
instance HandlerState (GHandler site) where
stateGHState f =
GHandler $ flip atomicModifyIORef f' . handlerState
where
f' z = let (x, y) = f z in (y, x)
instance HandlerState (GWidget sub master) where
instance HandlerState (GWidget site) where
stateGHState = lift . stateGHState
instance (MonadTrans t, HandlerState m, Monad (t m)) => HandlerState (t m) where
instance HandlerState m => HandlerState (HandlerT site m) where
stateGHState = lift . stateGHState
class HandlerReader m => HandlerError m where
handlerError :: HandlerContents -> m a
instance HandlerError (GHandler sub master) where
instance HandlerError (GHandler site) where
handlerError = throwIO
instance HandlerError (GWidget sub master) where
instance HandlerError (GWidget site) where
handlerError = lift . handlerError
instance (HandlerError m, MonadTrans t, Monad (t m)) => HandlerError (t m) where
instance HandlerError m => HandlerError (HandlerT site m) where
handlerError = lift . handlerError

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

@ -6,7 +6,8 @@ module Yesod.Core.Class.Yesod where
import Control.Monad.Logger (logErrorS)
import Yesod.Core.Content
import Yesod.Core.Handler hiding (getExpires)
import Yesod.Core.Handler
import Yesod.Core.Class.Handler
import Yesod.Routes.Class
@ -17,6 +18,8 @@ import Control.Monad (forM)
import Control.Monad.IO.Class (MonadIO (liftIO))
import Control.Monad.Logger (LogLevel (LevelInfo, LevelOther),
LogSource)
import Control.Monad.Trans.Resource
import Control.Monad.Trans.Control
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as L
import Data.Aeson (object, (.=))
@ -77,11 +80,11 @@ class RenderRoute a => Yesod a where
approot = ApprootRelative
-- | Output error response pages.
errorHandler :: ErrorResponse -> GHandler sub a TypedContent
errorHandler :: ErrorResponse -> GHandler a TypedContent
errorHandler = defaultErrorHandler
-- | Applies some form of layout to the contents of a page.
defaultLayout :: GWidget sub a () -> GHandler sub a RepHtml
defaultLayout :: GWidget a () -> GHandler a RepHtml
defaultLayout w = do
p <- widgetToPageContent w
mmsg <- getMessage
@ -112,7 +115,7 @@ $doctype 5
-- If authentication is required, return 'AuthenticationRequired'.
isAuthorized :: Route a
-> Bool -- ^ is this a write request?
-> GHandler s a AuthResult
-> GHandler a AuthResult
isAuthorized _ _ = return Authorized
-- | Determines whether the current request is a write request. By default,
@ -122,7 +125,7 @@ $doctype 5
--
-- This function is used to determine if a request is authorized; see
-- 'isAuthorized'.
isWriteRequest :: Route a -> GHandler s a Bool
isWriteRequest :: Route a -> GHandler a Bool
isWriteRequest _ = do
wai <- waiRequest
return $ W.requestMethod wai `notElem`
@ -188,7 +191,7 @@ $doctype 5
addStaticContent :: Text -- ^ filename extension
-> Text -- ^ mime-type
-> L.ByteString -- ^ content
-> GHandler sub a (Maybe (Either Text (Route a, [(Text, Text)])))
-> GHandler a (Maybe (Either Text (Route a, [(Text, Text)])))
addStaticContent _ _ _ = return Nothing
{- Temporarily disabled until we have a better interface.
@ -274,7 +277,7 @@ $doctype 5
-- performs authorization checks.
--
-- Since: 1.1.6
yesodMiddleware :: GHandler sub a res -> GHandler sub a res
yesodMiddleware :: GHandler a res -> GHandler a res
yesodMiddleware handler = do
setHeader "Vary" "Accept, Accept-Language"
route <- getCurrentRoute
@ -297,9 +300,9 @@ $doctype 5
handler
-- | Convert a widget to a 'PageContent'.
widgetToPageContent :: (Eq (Route master), Yesod master)
=> GWidget sub master ()
-> GHandler sub master (PageContent (Route master))
widgetToPageContent :: (Eq (Route site), Yesod site)
=> GWidget site ()
-> GHandler site (PageContent (Route site))
widgetToPageContent w = do
master <- getYesod
((), GWData (Body body) (Last mTitle) scripts' stylesheets' style jscript (Head head')) <- unGWidget w
@ -393,7 +396,7 @@ $newline never
runUniqueList (UniqueList x) = nub $ x []
-- | The default error handler for 'errorHandler'.
defaultErrorHandler :: Yesod y => ErrorResponse -> GHandler sub y TypedContent
defaultErrorHandler :: Yesod site => ErrorResponse -> GHandler site TypedContent
defaultErrorHandler NotFound = selectRep $ do
provideRep $ defaultLayout $ do
r <- lift waiRequest
@ -557,3 +560,14 @@ fileLocationToString loc = (loc_package loc) ++ ':' : (loc_module loc) ++
where
line = show . fst . loc_start
char = show . snd . loc_start
class (MonadBaseControl IO m, HandlerState m, HandlerError m, MonadResource m, Yesod (HandlerMaster m)) => MonadHandler m where
liftHandler :: GHandler (HandlerMaster m) a -> m a
askHandlerData :: m (HandlerData (HandlerSite m))
instance Yesod site => MonadHandler (GHandler site) where
liftHandler = id
askHandlerData = GHandler return
instance MonadHandler m => MonadHandler (HandlerT site m) where
liftHandler = lift . liftHandler
askHandlerData = HandlerT return

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

@ -122,8 +122,8 @@ mkYesodGeneral name args clazzes isSub resS = do
context = if isSub then cxt $ yesod : map return clazzes
else return []
yesod = classP ''HandlerReader [master]
handler = tySynD (mkName "Handler") [] [t| GHandler $master $master |]
widget = tySynD (mkName "Widget") [] [t| GWidget $master $master () |]
handler = tySynD (mkName "Handler") [] [t| GHandler $master |]
widget = tySynD (mkName "Widget") [] [t| GWidget $master () |]
res = map (fmap parseType) resS
subCons = conT $ mkName name
subArgs = map (varT. mkName) args
@ -139,7 +139,7 @@ mkDispatchInstance :: CxtQ -- ^ The context
-> [ResourceTree a] -- ^ The resource
-> DecsQ
mkDispatchInstance context _sub master res = do
let yDispatch = conT ''YesodDispatch `appT` master `appT` master
let yDispatch = conT ''YesodDispatch `appT` master
thisDispatch = do
clause' <- mkDispatchClause MkDispatchSettings
{ mdsRunHandler = [|yesodRunner|]
@ -199,38 +199,30 @@ mkYesodSubDispatch res = do
-- handler. This is the same as 'toWaiAppPlain', except it includes two
-- middlewares: GZIP compression and autohead. This is the
-- recommended approach for most users.
toWaiApp :: ( Yesod master
, YesodDispatch master master
) => master -> IO W.Application
toWaiApp :: YesodDispatch site => site -> IO W.Application
toWaiApp y = gzip (gzipSettings y) . autohead <$> toWaiAppPlain y
-- | Convert the given argument into a WAI application, executable with any WAI
-- handler. This differs from 'toWaiApp' in that it uses no middlewares.
toWaiAppPlain :: ( Yesod master
, YesodDispatch master master
) => master -> IO W.Application
toWaiAppPlain :: YesodDispatch site => site -> IO W.Application
toWaiAppPlain a = toWaiApp' a <$> getLogger a <*> makeSessionBackend a
toWaiApp' :: ( Yesod master
, YesodDispatch master master
)
=> master
toWaiApp' :: YesodDispatch site
=> site
-> Logger
-> Maybe SessionBackend
-> W.Application
toWaiApp' y logger sb req =
case cleanPath y $ W.pathInfo req of
Left pieces -> sendRedirect y pieces req
toWaiApp' site logger sb req =
case cleanPath site $ W.pathInfo req of
Left pieces -> sendRedirect site pieces req
Right pieces -> yesodDispatch yre req
{ W.pathInfo = pieces
}
where
yre = YesodRunnerEnv
{ yreLogger = logger
, yreMaster = y
, yreSub = y
, yreToMaster = id
, yreSite = site
, yreSessionBackend = sb
}

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

@ -25,12 +25,9 @@ module Yesod.Core.Handler
, HandlerT
-- ** Read information from handler
, getYesod
, getYesodSub
, getUrlRender
, getUrlRenderParams
, getCurrentRoute
, getCurrentRouteSub
, getRouteToMaster
, getRequest
, waiRequest
, runRequestBody
@ -132,7 +129,7 @@ import Yesod.Core.Internal.Request (langKey, mkFileInfoFile,
import Control.Applicative ((<$>), (<|>))
import Control.Monad (ap, liftM)
import Control.Monad (liftM)
import qualified Control.Monad.Trans.Writer as Writer
import Control.Monad.IO.Class (MonadIO, liftIO)
@ -233,16 +230,12 @@ rbHelper' backend mkFI req =
| otherwise = a'
go = decodeUtf8With lenientDecode
-- | Get the sub application argument.
getYesodSub :: HandlerReader m => m (HandlerSub m)
getYesodSub = rheSub `liftM` askHandlerEnv
-- | Get the master site appliation argument.
getYesod :: HandlerReader m => m (HandlerMaster m)
getYesod = rheMaster `liftM` askHandlerEnv
getYesod :: HandlerReader m => m (HandlerSite m)
getYesod = rheSite `liftM` askHandlerEnv
-- | Get the URL rendering function.
getUrlRender :: HandlerReader m => m (Route (HandlerMaster m) -> Text)
getUrlRender :: HandlerReader m => m (Route (HandlerSite m) -> Text)
getUrlRender = do
x <- rheRender `liftM` askHandlerEnv
return $ flip x []
@ -250,23 +243,13 @@ getUrlRender = do
-- | The URL rendering function with query-string parameters.
getUrlRenderParams
:: HandlerReader m
=> m (Route (HandlerMaster m) -> [(Text, Text)] -> Text)
=> m (Route (HandlerSite m) -> [(Text, Text)] -> Text)
getUrlRenderParams = rheRender `liftM` askHandlerEnv
-- | Get the route requested by the user. If this is a 404 response- where the
-- user requested an invalid route- this function will return 'Nothing'.
getCurrentRoute :: HandlerReader m => m (Maybe (Route (HandlerMaster m)))
getCurrentRoute = fmap `liftM` getRouteToMaster `ap` getCurrentRouteSub
-- | Same as 'getCurrentRoute', but for the subsite.
getCurrentRouteSub :: HandlerReader m => m (Maybe (Route (HandlerSub m)))
getCurrentRouteSub = rheRoute `liftM` askHandlerEnv
-- | Get the function to promote a route for a subsite to a route for the
-- master site.
getRouteToMaster :: HandlerReader m => m (Route (HandlerSub m) -> Route (HandlerMaster m))
getRouteToMaster = rheToMaster `liftM` askHandlerEnv
getCurrentRoute :: HandlerReader m => m (Maybe (Route (HandlerSite m)))
getCurrentRoute = rheRoute `liftM` askHandlerEnv
-- | Returns a function that runs 'GHandler' actions inside @IO@.
--
@ -304,7 +287,7 @@ getRouteToMaster = rheToMaster `liftM` 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 m => GHandler sub master (GHandler sub master a -> m a)
handlerToIO :: MonadIO m => GHandler site (GHandler site a -> m a)
handlerToIO =
GHandler $ \oldHandlerData -> do
-- Let go of the request body, cache and response headers.
@ -344,7 +327,7 @@ handlerToIO =
--
-- If you want direct control of the final status code, or need a different
-- status code, please use 'redirectWith'.
redirect :: (HandlerError m, RedirectUrl (HandlerMaster m) url, HandlerReader m)
redirect :: (HandlerError m, RedirectUrl (HandlerSite m) url, HandlerReader m)
=> url -> m a
redirect url = do
req <- waiRequest
@ -355,7 +338,7 @@ redirect url = do
redirectWith status url
-- | Redirect to the given URL with the specified status code.
redirectWith :: (HandlerError m, RedirectUrl (HandlerMaster m) url, HandlerReader m)
redirectWith :: (HandlerError m, RedirectUrl (HandlerSite m) url, HandlerReader m)
=> H.Status
-> url
-> m a
@ -370,7 +353,7 @@ ultDestKey = "_ULT"
--
-- An ultimate destination is stored in the user session and can be loaded
-- later by 'redirectUltDest'.
setUltDest :: (HandlerState m, RedirectUrl (HandlerMaster m) url)
setUltDest :: (HandlerState m, RedirectUrl (HandlerSite m) url)
=> url
-> m ()
setUltDest url = do
@ -410,7 +393,7 @@ setUltDestReferer = do
--
-- This function uses 'redirect', and thus will perform a temporary redirect to
-- a GET request.
redirectUltDest :: (RedirectUrl (HandlerMaster m) url, HandlerState m, HandlerError m)
redirectUltDest :: (RedirectUrl (HandlerSite m) url, HandlerState m, HandlerError m)
=> url -- ^ default destination if nothing in session
-> m a
redirectUltDest def = do
@ -434,7 +417,7 @@ setMessage = setSession msgKey . T.concat . TL.toChunks . RenderText.renderHtml
-- | Sets a message in the user's session.
--
-- See 'getMessage'.
setMessageI :: (HandlerState m, RenderMessage (HandlerMaster m) msg)
setMessageI :: (HandlerState m, RenderMessage (HandlerSite m) msg)
=> msg -> m ()
setMessageI msg = do
mr <- getMessageRender
@ -479,7 +462,7 @@ sendResponseStatus s = handlerError . HCContent s . toTypedContent
-- | Send a 201 "Created" response with the given route as the Location
-- response header.
sendResponseCreated :: HandlerError m => Route (HandlerMaster m) -> m a
sendResponseCreated :: HandlerError m => Route (HandlerSite m) -> m a
sendResponseCreated url = do
r <- getUrlRender
handlerError $ HCCreated $ r url
@ -507,7 +490,7 @@ permissionDenied :: HandlerError m => Text -> m a
permissionDenied = hcError . PermissionDenied
-- | Return a 403 permission denied page.
permissionDeniedI :: (RenderMessage (HandlerMaster m) msg, HandlerError m)
permissionDeniedI :: (RenderMessage (HandlerSite m) msg, HandlerError m)
=> msg
-> m a
permissionDeniedI msg = do
@ -519,7 +502,7 @@ invalidArgs :: HandlerError m => [Text] -> m a
invalidArgs = hcError . InvalidArgs
-- | Return a 400 invalid arguments page.
invalidArgsI :: (HandlerError m, RenderMessage (HandlerMaster m) msg) => [msg] -> m a
invalidArgsI :: (HandlerError m, RenderMessage (HandlerSite m) msg) => [msg] -> m a
invalidArgsI msg = do
mr <- getMessageRender
invalidArgs $ map mr msg
@ -623,7 +606,7 @@ addHeader = tell . Endo . (:)
-- | Some value which can be turned into a URL for redirects.
class RedirectUrl master a where
-- | Converts the value to the URL and a list of query-string parameters.
toTextUrl :: (HandlerReader m, HandlerMaster m ~ master) => a -> m Text
toTextUrl :: (HandlerReader m, HandlerSite m ~ master) => a -> m Text
instance RedirectUrl master Text where
toTextUrl = return
@ -672,7 +655,7 @@ newIdent = do
-- POST form, and some Javascript to automatically submit the form. This can be
-- useful when you need to post a plain link somewhere that needs to cause
-- changes on the server.
redirectToPost :: (HandlerError m, RedirectUrl (HandlerMaster m) url)
redirectToPost :: (HandlerError m, RedirectUrl (HandlerSite m) url)
=> url
-> m a
redirectToPost url = do
@ -692,7 +675,7 @@ $doctype 5
|] >>= sendResponse
-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.
hamletToRepHtml :: HandlerReader m => HtmlUrl (Route (HandlerMaster m)) -> m Html
hamletToRepHtml :: HandlerReader m => HtmlUrl (Route (HandlerSite m)) -> m Html
hamletToRepHtml = giveUrlRenderer
-- | Provide a URL rendering function to the given function and return the
@ -700,7 +683,7 @@ hamletToRepHtml = giveUrlRenderer
--
-- Since 1.2.0
giveUrlRenderer :: HandlerReader m
=> ((Route (HandlerMaster m) -> [(Text, Text)] -> Text) -> output)
=> ((Route (HandlerSite m) -> [(Text, Text)] -> Text) -> output)
-> m output
giveUrlRenderer f = do
render <- getUrlRenderParams
@ -710,7 +693,7 @@ giveUrlRenderer f = do
waiRequest :: HandlerReader m => m W.Request
waiRequest = reqWaiRequest `liftM` getRequest
getMessageRender :: (HandlerReader m, RenderMessage (HandlerMaster m) message)
getMessageRender :: (HandlerReader m, RenderMessage (HandlerSite m) message)
=> m (message -> Text)
getMessageRender = do
m <- getYesod

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

@ -11,10 +11,9 @@ import Yesod.Core.Class.Handler
import Blaze.ByteString.Builder (toByteString)
import Control.Applicative ((<$>))
import Control.Exception (fromException)
import Control.Exception.Lifted (catch, finally)
import Control.Exception.Lifted (catch)
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Base (liftBase)
import Control.Monad.Logger (LogLevel (LevelError), LogSource,
liftLoc)
import Control.Monad.Trans.Resource (runResourceT)
@ -48,8 +47,8 @@ import Yesod.Routes.Class (Route, renderRoute)
-- | Function used internally by Yesod in the process of converting a
-- 'GHandler' into an 'Application'. Should not be needed by users.
runHandler :: ToTypedContent c
=> RunHandlerEnv sub master
-> GHandler sub master c
=> RunHandlerEnv site
-> GHandler site c
-> YesodApp
runHandler rhe@RunHandlerEnv {..} handler yreq = do
let toErrorHandler e =
@ -149,25 +148,23 @@ safeEh log' er req = do
-- @GHandler@ is completely ignored, including changes to the
-- session, cookies or headers. We only return you the
-- @GHandler@'s return value.
runFakeHandler :: (Yesod master, MonadIO m) =>
runFakeHandler :: (Yesod site, MonadIO m) =>
SessionMap
-> (master -> Logger)
-> master
-> GHandler master master a
-> (site -> Logger)
-> site
-> GHandler site a
-> m (Either ErrorResponse a)
runFakeHandler fakeSessionMap logger master handler = liftIO $ do
runFakeHandler fakeSessionMap logger site handler = liftIO $ do
ret <- I.newIORef (Left $ InternalError "runFakeHandler: no result")
let handler' = do liftIO . I.writeIORef ret . Right =<< handler
return ()
let yapp = runHandler
RunHandlerEnv
{ rheRender = yesodRender master $ resolveApproot master fakeWaiRequest
{ rheRender = yesodRender site $ resolveApproot site fakeWaiRequest
, rheRoute = Nothing
, rheToMaster = id
, rheMaster = master
, rheSub = master
, rheUpload = fileUpload master
, rheLog = messageLoggerSource master $ logger master
, rheSite = site
, rheUpload = fileUpload site
, rheLog = messageLoggerSource site $ logger site
, rheOnError = errHandler
}
handler'
@ -210,10 +207,10 @@ runFakeHandler fakeSessionMap logger master handler = liftIO $ do
I.readIORef ret
{-# WARNING runFakeHandler "Usually you should *not* use runFakeHandler unless you really understand how it works and why you need it." #-}
yesodRunner :: (ToTypedContent res, Yesod master)
=> GHandler sub master res
-> YesodRunnerEnv sub master
-> Maybe (Route sub)
yesodRunner :: (ToTypedContent res, Yesod site)
=> GHandler site res
-> YesodRunnerEnv site
-> Maybe (Route site)
-> Application
yesodRunner handler' YesodRunnerEnv {..} route req
| KnownLength len <- requestBodyLength req, maxLen < len = return tooLargeResponse
@ -226,19 +223,17 @@ yesodRunner handler' YesodRunnerEnv {..} route req
case mkYesodReq of
Left yreq -> return yreq
Right needGen -> liftIO $ needGen <$> newStdGen
let ra = resolveApproot yreMaster req
let log' = messageLoggerSource yreMaster yreLogger
let ra = resolveApproot yreSite req
let log' = messageLoggerSource yreSite yreLogger
-- We set up two environments: the first one has a "safe" error handler
-- which will never throw an exception. The second one uses the
-- user-provided errorHandler function. If that errorHandler function
-- errors out, it will use the safeEh below to recover.
rheSafe = RunHandlerEnv
{ rheRender = yesodRender yreMaster ra
{ rheRender = yesodRender yreSite ra
, rheRoute = route
, rheToMaster = yreToMaster
, rheMaster = yreMaster
, rheSub = yreSub
, rheUpload = fileUpload yreMaster
, rheSite = yreSite
, rheUpload = fileUpload yreSite
, rheLog = log'
, rheOnError = safeEh log'
}
@ -248,7 +243,7 @@ yesodRunner handler' YesodRunnerEnv {..} route req
yar <- runHandler rhe handler yreq
liftIO $ yarToResponse yar saveSession yreq
where
maxLen = maximumContentLength yreMaster $ fmap yreToMaster route
maxLen = maximumContentLength yreSite route
handler = yesodMiddleware handler'
yesodRender :: Yesod y
@ -274,38 +269,20 @@ resolveApproot master req =
ApprootMaster f -> f master
ApprootRequest f -> f master req
fixEnv :: (oldSub -> newSub)
-> (Route newSub -> Route oldSub)
-> YesodRunnerEnv oldSub master
-> YesodRunnerEnv newSub master
fixEnv toNewSub toOldRoute envOld =
envOld
{ yreSub = toNewSub $ yreSub envOld
, yreToMaster = yreToMaster envOld . toOldRoute
}
stripHandlerT :: (HandlerState m, MonadBaseControl IO m)
stripHandlerT :: (MonadHandler m, MonadBaseControl IO m)
=> HandlerT sub m a
-> (HandlerMaster m -> sub)
-> (Route sub -> Route (HandlerMaster m))
-> (HandlerSite m -> sub)
-> (Route sub -> Route (HandlerSite m))
-> Maybe (Route sub)
-> m a
stripHandlerT (HandlerT f) getSub toMaster newRoute = do
yreq <- askYesodRequest
env <- askHandlerEnv
ghs <- getGHState
ighs <- liftBase $ I.newIORef ghs
hd <- askHandlerData
let sub = getSub $ rheMaster env
hd = HandlerData
{ handlerRequest = yreq
, handlerEnv = env
{ rheMaster = sub
, rheSub = sub
, rheToMaster = id
, rheRoute = newRoute
, rheRender = \url params -> rheRender env (toMaster url) params
}
, handlerState = ighs
let env = handlerEnv hd
f hd
{ handlerEnv = env
{ rheSite = getSub $ rheSite env
, rheRoute = newRoute
, rheRender = \url params -> rheRender env (toMaster url) params
}
f hd `finally` (liftBase (I.readIORef ighs) >>= putGHState)
}

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

@ -44,10 +44,10 @@ import Data.Maybe (listToMaybe)
-- ('defaultLayout').
--
-- /Since: 0.3.0/
defaultLayoutJson :: (Yesod master, J.ToJSON a)
=> GWidget sub master () -- ^ HTML
-> GHandler sub master a -- ^ JSON
-> GHandler sub master TypedContent
defaultLayoutJson :: (Yesod site, J.ToJSON a)
=> GWidget site () -- ^ HTML
-> GHandler site a -- ^ JSON
-> GHandler site TypedContent
defaultLayoutJson w json = selectRep $ do
provideRep $ defaultLayout w
provideRep $ fmap J.toJSON json
@ -56,7 +56,7 @@ defaultLayoutJson w json = selectRep $ do
-- support conversion to JSON via 'J.ToJSON'.
--
-- /Since: 0.3.0/
jsonToRepJson :: J.ToJSON a => a -> GHandler sub master J.Value
jsonToRepJson :: J.ToJSON a => a -> GHandler site J.Value
jsonToRepJson = return . J.toJSON
-- | Parse the request body to a data type as a JSON value. The
@ -65,7 +65,7 @@ jsonToRepJson = return . J.toJSON
-- 'J.Value'@.
--
-- /Since: 0.3.0/
parseJsonBody :: J.FromJSON a => GHandler sub master (J.Result a)
parseJsonBody :: J.FromJSON a => GHandler site (J.Result a)
parseJsonBody = do
req <- waiRequest
eValue <- lift
@ -78,7 +78,7 @@ parseJsonBody = do
-- | Same as 'parseJsonBody', but return an invalid args response on a parse
-- error.
parseJsonBody_ :: J.FromJSON a => GHandler sub master a
parseJsonBody_ :: J.FromJSON a => GHandler site a
parseJsonBody_ = do
ra <- parseJsonBody
case ra of
@ -96,10 +96,10 @@ array = J.Array . V.fromList . map J.toJSON
-- @application\/json@ (e.g. AJAX, see 'acceptsJSON').
--
-- 2. 3xx otherwise, following the PRG pattern.
jsonOrRedirect :: (Yesod master, J.ToJSON a)
=> Route master -- ^ Redirect target
jsonOrRedirect :: (Yesod site, J.ToJSON a)
=> Route site -- ^ Redirect target
-> a -- ^ Data to send via JSON
-> GHandler sub master J.Value
-> GHandler site J.Value
jsonOrRedirect r j = do
q <- acceptsJson
if q then jsonToRepJson (J.toJSON j)
@ -107,7 +107,7 @@ jsonOrRedirect r j = do
-- | Returns @True@ if the client prefers @application\/json@ as
-- indicated by the @Accept@ HTTP header.
acceptsJson :: Yesod master => GHandler sub master Bool
acceptsJson :: Yesod site => GHandler site Bool
acceptsJson = maybe False ((== "application/json") . B8.takeWhile (/= ';'))
. join
. fmap (listToMaybe . parseHttpAccept)

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

@ -166,12 +166,10 @@ type Texts = [Text]
-- | Wrap up a normal WAI application as a Yesod subsite.
newtype WaiSubsite = WaiSubsite { runWaiSubsite :: W.Application }
data RunHandlerEnv sub master = RunHandlerEnv
{ rheRender :: !(Route master -> [(Text, Text)] -> Text)
, rheRoute :: !(Maybe (Route sub))
, rheToMaster :: !(Route sub -> Route master)
, rheMaster :: !master
, rheSub :: !sub
data RunHandlerEnv site = RunHandlerEnv
{ rheRender :: !(Route site -> [(Text, Text)] -> Text)
, rheRoute :: !(Maybe (Route site))
, rheSite :: !site
, rheUpload :: !(RequestBodyLength -> FileUpload)
, rheLog :: !(Loc -> LogSource -> LogLevel -> LogStr -> IO ())
, rheOnError :: !(ErrorResponse -> YesodApp)
@ -180,28 +178,26 @@ data RunHandlerEnv sub master = RunHandlerEnv
-- Since 1.2.0
}
data HandlerData sub master = HandlerData
data HandlerData site = HandlerData
{ handlerRequest :: !YesodRequest
, handlerEnv :: !(RunHandlerEnv sub master)
, handlerEnv :: !(RunHandlerEnv site)
, handlerState :: !(IORef GHState)
}
data YesodRunnerEnv sub master = YesodRunnerEnv
data YesodRunnerEnv site = YesodRunnerEnv
{ yreLogger :: !Logger
, yreMaster :: !master
, yreSub :: !sub
, yreToMaster :: !(Route sub -> Route master)
, yreSite :: !site
, yreSessionBackend :: !(Maybe SessionBackend)
}
-- | A generic handler monad, which can have a different subsite and master
-- site. We define a newtype for better error message.
newtype GHandler sub master a = GHandler
{ unGHandler :: HandlerData sub master -> ResourceT IO a
newtype GHandler site a = GHandler
{ unGHandler :: HandlerData site -> ResourceT IO a
}
newtype HandlerT sub m a = HandlerT
{ unHandlerT :: HandlerData sub sub -> m a
newtype HandlerT site m a = HandlerT
{ unHandlerT :: HandlerData site -> m a
}
instance Monad m => Monad (HandlerT sub m) where
@ -229,11 +225,11 @@ 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 GWidget sub master a = GWidget
{ unGWidget :: GHandler sub master (a, GWData (Route master))
newtype GWidget site a = GWidget -- FIXME change to WidgetT?
{ unGWidget :: GHandler site (a, GWData (Route site))
}
instance (a ~ ()) => Monoid (GWidget sub master a) where
instance (a ~ ()) => Monoid (GWidget site a) where
mempty = return ()
mappend x y = x >> y
@ -349,60 +345,60 @@ instance Show HandlerContents where
instance Exception HandlerContents
-- Instances for GWidget
instance Functor (GWidget sub master) where
instance Functor (GWidget site) where
fmap f (GWidget x) = GWidget (fmap (first f) x)
instance Applicative (GWidget sub master) where
instance Applicative (GWidget site) where
pure a = GWidget $ pure (a, mempty)
GWidget f <*> GWidget v =
GWidget $ k <$> f <*> v
where
k (a, wa) (b, wb) = (a b, wa `mappend` wb)
instance Monad (GWidget sub master) where
instance Monad (GWidget site) where
return = pure
GWidget x >>= f = GWidget $ do
(a, wa) <- x
(b, wb) <- unGWidget (f a)
return (b, wa `mappend` wb)
instance MonadIO (GWidget sub master) where
instance MonadIO (GWidget site) where
liftIO = GWidget . fmap (\a -> (a, mempty)) . liftIO
instance MonadBase IO (GWidget sub master) where
instance MonadBase IO (GWidget site) where
liftBase = GWidget . fmap (\a -> (a, mempty)) . liftBase
instance MonadBaseControl IO (GWidget sub master) where
data StM (GWidget sub master) a =
StW (StM (GHandler sub master) (a, GWData (Route master)))
instance MonadBaseControl IO (GWidget site) where
data StM (GWidget site) a =
StW (StM (GHandler site) (a, GWData (Route site)))
liftBaseWith f = GWidget $ liftBaseWith $ \runInBase ->
liftM (\x -> (x, mempty))
(f $ liftM StW . runInBase . unGWidget)
restoreM (StW base) = GWidget $ restoreM base
instance MonadUnsafeIO (GWidget sub master) where
instance MonadUnsafeIO (GWidget site) where
unsafeLiftIO = liftIO
instance MonadThrow (GWidget sub master) where
instance MonadThrow (GWidget site) where
monadThrow = liftIO . throwIO
instance MonadResource (GWidget sub master) where
instance MonadResource (GWidget site) where
liftResourceT = lift . liftResourceT
instance MonadLogger (GWidget sub master) where
instance MonadLogger (GWidget site) where
monadLoggerLog a b c = lift . monadLoggerLog a b c
instance MonadLift (GHandler sub master) (GWidget sub master) where
instance MonadLift (GHandler site) (GWidget site) where
lift = GWidget . fmap (\x -> (x, mempty))
instance MonadLift (ResourceT IO) (GHandler sub master) where
instance MonadLift (ResourceT IO) (GHandler site) where
lift = GHandler . const
-- Instances for GHandler
instance Functor (GHandler sub master) where
instance Functor (GHandler site) where
fmap f (GHandler x) = GHandler $ \r -> fmap f (x r)
instance Applicative (GHandler sub master) where
instance Applicative (GHandler site) where
pure = GHandler . const . pure
GHandler f <*> GHandler x = GHandler $ \r -> f r <*> x r
instance Monad (GHandler sub master) where
instance Monad (GHandler site) where
return = pure
GHandler x >>= f = GHandler $ \r -> x r >>= \x' -> unGHandler (f x') r
instance MonadIO (GHandler sub master) where
instance MonadIO (GHandler site) where
liftIO = GHandler . const . lift
instance MonadBase IO (GHandler sub master) where
instance MonadBase IO (GHandler site) where
liftBase = GHandler . const . lift
-- | Note: although we provide a @MonadBaseControl@ instance, @lifted-base@'s
-- @fork@ function is incompatible with the underlying @ResourceT@ system.
@ -412,25 +408,25 @@ instance MonadBase IO (GHandler sub master) 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 IO (GHandler sub master) where
data StM (GHandler sub master) a = StH (StM (ResourceT IO) a)
instance MonadBaseControl IO (GHandler site) where
data StM (GHandler site) a = StH (StM (ResourceT IO) a)
liftBaseWith f = GHandler $ \reader ->
liftBaseWith $ \runInBase ->
f $ liftM StH . runInBase . (\(GHandler r) -> r reader)
restoreM (StH base) = GHandler $ const $ restoreM base
instance MonadUnsafeIO (GHandler sub master) where
instance MonadUnsafeIO (GHandler site) where
unsafeLiftIO = liftIO
instance MonadThrow (GHandler sub master) where
instance MonadThrow (GHandler site) where
monadThrow = liftIO . throwIO
instance MonadResource (GHandler sub master) where
instance MonadResource (GHandler site) where
liftResourceT = lift . liftResourceT
instance MonadLogger (GHandler sub master) where
instance MonadLogger (GHandler site) where
monadLoggerLog a b c d = GHandler $ \hd ->
liftIO $ rheLog (handlerEnv hd) a b c (toLogStr d)
instance Exception e => Failure e (GHandler sub master) where
instance Exception e => Failure e (GHandler site) where
failure = liftIO . throwIO
instance Monoid (UniqueList x) where

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

@ -25,8 +25,6 @@ module Yesod.Core.Widget
-- ** Head of page
, setTitle
, setTitleI
-- ** Body
, addSubWidget
-- ** CSS
, addStylesheet
, addStylesheetAttrs
@ -70,121 +68,109 @@ import Yesod.Core.Types
preEscapedLazyText :: TL.Text -> Html
preEscapedLazyText = preEscapedToMarkup
addSubWidget :: (Route sub -> Route master) -> sub -> GWidget sub master a -> GWidget sub' master a
addSubWidget toMaster sub (GWidget (GHandler f)) =
GWidget $ GHandler $ f . modHD
where
modHD hd = hd
{ handlerEnv = (handlerEnv hd)
{ rheRoute = Nothing
, rheSub = sub
, rheToMaster = toMaster
}
}
class ToWidget site a where
toWidget :: a -> GWidget site ()
class ToWidget sub master a where
toWidget :: a -> GWidget sub master ()
instance render ~ RY master => ToWidget sub master (render -> Html) where
instance render ~ RY site => ToWidget site (render -> Html) where
toWidget x = tell $ GWData (Body x) mempty mempty mempty mempty mempty mempty
instance render ~ RY master => ToWidget sub master (render -> Css) where
instance render ~ RY site => ToWidget site (render -> Css) where
toWidget x = toWidget $ CssBuilder . fromLazyText . renderCss . x
instance render ~ RY master => ToWidget sub master (render -> CssBuilder) where
instance render ~ RY site => ToWidget site (render -> CssBuilder) where
toWidget x = tell $ GWData mempty mempty mempty mempty (Map.singleton Nothing $ unCssBuilder . x) mempty mempty
instance render ~ RY master => ToWidget sub master (render -> Javascript) where
instance render ~ RY site => ToWidget site (render -> Javascript) where
toWidget x = tell $ GWData mempty mempty mempty mempty mempty (Just x) mempty
instance (sub' ~ sub, master' ~ master) => ToWidget sub' master' (GWidget sub master ()) where
instance (site' ~ site) => ToWidget site' (GWidget site ()) where
toWidget = id
instance ToWidget sub master Html where
instance ToWidget site Html where
toWidget = toWidget . const
-- | Allows adding some CSS to the page with a specific media type.
--
-- Since 1.2
class ToWidgetMedia sub master a where
class ToWidgetMedia site a where
-- | Add the given content to the page, but only for the given media type.
--
-- Since 1.2
toWidgetMedia :: Text -- ^ media value
-> a
-> GWidget sub master ()
instance render ~ RY master => ToWidgetMedia sub master (render -> Css) where
-> GWidget site ()
instance render ~ RY site => ToWidgetMedia site (render -> Css) where
toWidgetMedia media x = toWidgetMedia media $ CssBuilder . fromLazyText . renderCss . x
instance render ~ RY master => ToWidgetMedia sub master (render -> CssBuilder) where
instance render ~ RY site => ToWidgetMedia site (render -> CssBuilder) where
toWidgetMedia media x = tell $ GWData mempty mempty mempty mempty (Map.singleton (Just media) $ unCssBuilder . x) mempty mempty
class ToWidgetBody sub master a where
toWidgetBody :: a -> GWidget sub master ()
class ToWidgetBody site a where
toWidgetBody :: a -> GWidget site ()
instance render ~ RY master => ToWidgetBody sub master (render -> Html) where
instance render ~ RY site => ToWidgetBody site (render -> Html) where
toWidgetBody = toWidget
instance render ~ RY master => ToWidgetBody sub master (render -> Javascript) where
instance render ~ RY site => ToWidgetBody site (render -> Javascript) where
toWidgetBody j = toWidget $ \r -> H.script $ preEscapedLazyText $ renderJavascriptUrl r j
instance ToWidgetBody sub master Html where
instance ToWidgetBody site Html where
toWidgetBody = toWidget
class ToWidgetHead sub master a where
toWidgetHead :: a -> GWidget sub master ()
class ToWidgetHead site a where
toWidgetHead :: a -> GWidget site ()
instance render ~ RY master => ToWidgetHead sub master (render -> Html) where
instance render ~ RY site => ToWidgetHead site (render -> Html) where
toWidgetHead = tell . GWData mempty mempty mempty mempty mempty mempty . Head
instance render ~ RY master => ToWidgetHead sub master (render -> Css) where
instance render ~ RY site => ToWidgetHead site (render -> Css) where
toWidgetHead = toWidget
instance render ~ RY master => ToWidgetHead sub master (render -> CssBuilder) where
instance render ~ RY site => ToWidgetHead site (render -> CssBuilder) where
toWidgetHead = toWidget
instance render ~ RY master => ToWidgetHead sub master (render -> Javascript) where
instance render ~ RY site => ToWidgetHead site (render -> Javascript) where
toWidgetHead j = toWidgetHead $ \r -> H.script $ preEscapedLazyText $ renderJavascriptUrl r j
instance ToWidgetHead sub master Html where
instance ToWidgetHead site Html where
toWidgetHead = toWidgetHead . const
-- | Set the page title. Calling 'setTitle' multiple times overrides previously
-- set values.
setTitle :: Html -> GWidget sub master ()
setTitle :: Html -> GWidget site ()
setTitle x = tell $ GWData mempty (Last $ Just $ Title x) mempty mempty mempty mempty mempty
-- | Set the page title. Calling 'setTitle' multiple times overrides previously
-- set values.
setTitleI :: RenderMessage master msg => msg -> GWidget sub master ()
setTitleI :: RenderMessage site msg => msg -> GWidget site ()
setTitleI msg = do
mr <- lift getMessageRender
setTitle $ toHtml $ mr msg
-- | Link to the specified local stylesheet.
addStylesheet :: Route master -> GWidget sub master ()
addStylesheet :: Route site -> GWidget site ()
addStylesheet = flip addStylesheetAttrs []
-- | Link to the specified local stylesheet.
addStylesheetAttrs :: Route master -> [(Text, Text)] -> GWidget sub master ()
addStylesheetAttrs :: Route site -> [(Text, Text)] -> GWidget site ()
addStylesheetAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Local x) y) mempty mempty mempty
-- | Link to the specified remote stylesheet.
addStylesheetRemote :: Text -> GWidget sub master ()
addStylesheetRemote :: Text -> GWidget site ()
addStylesheetRemote = flip addStylesheetRemoteAttrs []
-- | Link to the specified remote stylesheet.
addStylesheetRemoteAttrs :: Text -> [(Text, Text)] -> GWidget sub master ()
addStylesheetRemoteAttrs :: Text -> [(Text, Text)] -> GWidget site ()
addStylesheetRemoteAttrs x y = tell $ GWData mempty mempty mempty (toUnique $ Stylesheet (Remote x) y) mempty mempty mempty
addStylesheetEither :: Either (Route master) Text -> GWidget sub master ()
addStylesheetEither :: Either (Route site) Text -> GWidget site ()
addStylesheetEither = either addStylesheet addStylesheetRemote
addScriptEither :: Either (Route master) Text -> GWidget sub master ()
addScriptEither :: Either (Route site) Text -> GWidget site ()
addScriptEither = either addScript addScriptRemote
-- | Link to the specified local script.
addScript :: Route master -> GWidget sub master ()
addScript :: Route site -> GWidget site ()
addScript = flip addScriptAttrs []
-- | Link to the specified local script.
addScriptAttrs :: Route master -> [(Text, Text)] -> GWidget sub master ()
addScriptAttrs :: Route site -> [(Text, Text)] -> GWidget site ()
addScriptAttrs x y = tell $ GWData mempty mempty (toUnique $ Script (Local x) y) mempty mempty mempty mempty
-- | Link to the specified remote script.
addScriptRemote :: Text -> GWidget sub master ()
addScriptRemote :: Text -> GWidget site ()
addScriptRemote = flip addScriptRemoteAttrs []
-- | Link to the specified remote script.
addScriptRemoteAttrs :: Text -> [(Text, Text)] -> GWidget sub master ()
addScriptRemoteAttrs :: Text -> [(Text, Text)] -> GWidget site ()
addScriptRemoteAttrs x y = tell $ GWData mempty mempty (toUnique $ Script (Remote x) y) mempty mempty mempty mempty
whamlet :: QuasiQuoter
@ -214,20 +200,20 @@ rules = do
return $ NP.HamletRules ah ur $ \_ b -> return $ ah `AppE` b
-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.
ihamletToRepHtml :: RenderMessage master message
=> HtmlUrlI18n message (Route master)
-> GHandler sub master Html
ihamletToRepHtml :: RenderMessage site message
=> HtmlUrlI18n message (Route site)
-> GHandler site Html
ihamletToRepHtml ih = do
urender <- getUrlRenderParams
mrender <- getMessageRender
return $ ih (toHtml . mrender) urender
tell :: GWData (Route master) -> GWidget sub master ()
tell :: GWData (Route site) -> GWidget site ()
tell w = GWidget $ return ((), w)
-- | Type-restricted version of @lift@. Used internally to create better error
-- messages.
liftW :: GHandler sub master a -> GWidget sub master a
liftW :: GHandler site a -> GWidget site a
liftW = lift
toUnique :: x -> UniqueList x

2
yesod-core/test/YesodCoreTest/JsLoader.hs
View File

@ -30,5 +30,5 @@ specs = describe "Test.JsLoader" $ do
res <- request defaultRequest
assertBody "<!DOCTYPE html>\n<html><head><title></title></head><body><script src=\"load.js\"></script></body></html>" res
runner :: (YesodDispatch master master, Yesod master) => master -> Session () -> IO ()
runner :: YesodDispatch master => master -> Session () -> IO ()
runner app f = toWaiApp app >>= runSession f

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

@ -15,16 +15,16 @@ import qualified Data.ByteString.Lazy.Char8 as L8
getSubsite :: a -> Subsite
getSubsite = const Subsite
instance YesodSubDispatch Subsite (GHandler master master) where
instance YesodSubDispatch Subsite (GHandler master) where
yesodSubDispatch = $(mkYesodSubDispatch resourcesSubsite)
getBarR :: Monad m => m T.Text
getBarR = return $ T.pack "BarR"
getBazR :: Yesod master => HandlerT Subsite (GHandler master master) RepHtml
getBazR :: Yesod master => HandlerT Subsite (GHandler master) RepHtml
getBazR = lift $ defaultLayout [whamlet|Used Default Layout|]
getBinR :: MonadHandlerBase m => HandlerT Subsite m RepHtml
getBinR :: MonadHandler m => HandlerT Subsite m RepHtml
getBinR = defaultLayoutT
[whamlet|
<p>Used defaultLayoutT

2
yesod-core/test/YesodCoreTest/YesodTest.hs
View File

@ -14,5 +14,5 @@ import Network.Wai.Test
import Network.Wai
import Test.Hspec
yesod :: (YesodDispatch y y, Yesod y) => y -> Session a -> IO a
yesod :: YesodDispatch y => y -> Session a -> IO a
yesod app f = toWaiApp app >>= runSession f