Beginning of modifications to dispatch code for more powerful subsites
This commit is contained in:
Michael Snoyman
parent
fddfd9bcf1
commit
ee3fc92111
@ -17,7 +17,6 @@ module Yesod.Core
|
||||
-- * Utitlities
|
||||
, maybeAuthorized
|
||||
, widgetToPageContent
|
||||
, redirectToPost
|
||||
-- * Defaults
|
||||
, defaultErrorHandler
|
||||
-- * Data types
|
||||
@ -46,6 +45,7 @@ import qualified Web.ClientSession as CS
|
||||
import qualified Data.ByteString as S
|
||||
import qualified Data.ByteString.Char8 as S8
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import qualified Data.ByteString.Lazy.Char8 as L8
|
||||
import Data.Monoid
|
||||
import Control.Monad.Trans.Writer
|
||||
import Control.Monad.Trans.State hiding (get, put)
|
||||
@ -77,10 +77,7 @@ import qualified Data.Text.Encoding
|
||||
#define HAMLET $hamlet
|
||||
#endif
|
||||
|
||||
{- FIXME
|
||||
class YesodDispatcher y where
|
||||
dispatchSubsite :: y -> Key -> [String] -> Maybe Application
|
||||
-}
|
||||
-- FIXME ditch the whole Site thing and just have render and dispatch?
|
||||
|
||||
-- | This class is automatically instantiated when you use the template haskell
|
||||
-- mkYesod function. You should never need to deal with it directly.
|
||||
@ -88,6 +85,7 @@ class Eq (Route y) => YesodSite y where
|
||||
getSite :: Site (Route y) (Method -> Maybe (GHandler y y ChooseRep))
|
||||
getSite' :: y -> Site (Route y) (Method -> Maybe (GHandler y y ChooseRep))
|
||||
getSite' _ = getSite
|
||||
dispatchToSubsite :: y -> Maybe CS.Key -> [String] -> Maybe W.Application
|
||||
|
||||
type Method = String
|
||||
|
||||
@ -95,6 +93,8 @@ type Method = String
|
||||
-- to deal with it directly, as mkYesodSub creates instances appropriately.
|
||||
class Eq (Route s) => YesodSubSite s y where
|
||||
getSubSite :: Site (Route s) (Method -> Maybe (GHandler s y ChooseRep))
|
||||
dispatchSubsite :: y -> Maybe CS.Key -> [String] -> (y -> s) -> W.Application
|
||||
dispatchSubsite _ _ _ _ _ = return $ W.responseLBS W.status200 [("Content-Type", "text/plain")] $ L8.pack "FIXME"
|
||||
|
||||
-- | Define settings for a Yesod applications. The only required setting is
|
||||
-- 'approot'; other than that, there are intelligent defaults.
|
||||
@ -156,8 +156,6 @@ class Eq (Route a) => Yesod a where
|
||||
-- Return 'Nothing' is the request is authorized, 'Just' a message if
|
||||
-- unauthorized. If authentication is required, you should use a redirect;
|
||||
-- the Auth helper provides this functionality automatically.
|
||||
--
|
||||
-- FIXME make this a part of the Yesod middlewares
|
||||
isAuthorized :: Route a
|
||||
-> Bool -- ^ is this a write request?
|
||||
-> GHandler s a AuthResult
|
||||
@ -485,6 +483,21 @@ $maybe j <- jscript
|
||||
|]
|
||||
return $ PageContent title head'' body
|
||||
|
||||
yesodVersion :: String
|
||||
yesodVersion = showVersion Paths_yesod_core.version
|
||||
|
||||
yesodRender :: (Yesod y, YesodSite y)
|
||||
=> y
|
||||
-> Route y
|
||||
-> [(String, String)]
|
||||
-> String
|
||||
yesodRender y u qs =
|
||||
S8.unpack $ fromMaybe
|
||||
(joinPath y (approot y) ps $ qs ++ qs')
|
||||
(urlRenderOverride y u)
|
||||
where
|
||||
(ps, qs') = formatPathSegments (getSite' y) u
|
||||
|
||||
#if TEST
|
||||
coreTestSuite :: Test
|
||||
coreTestSuite = testGroup "Yesod.Yesod"
|
||||
@ -535,43 +548,3 @@ caseUtf8JoinPath :: Assertion
|
||||
caseUtf8JoinPath = do
|
||||
"/%D7%A9%D7%9C%D7%95%D7%9D/" @=? joinPath TmpYesod "" ["שלום"] []
|
||||
#endif
|
||||
|
||||
-- | Redirect to a POST resource.
|
||||
--
|
||||
-- This is not technically a redirect; instead, it returns an HTML page with a
|
||||
-- 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 :: Route master -> GHandler sub master a
|
||||
redirectToPost dest = hamletToRepHtml
|
||||
#if GHC7
|
||||
[hamlet|
|
||||
#else
|
||||
[$hamlet|
|
||||
#endif
|
||||
\<!DOCTYPE html>
|
||||
|
||||
<html>
|
||||
<head>
|
||||
<title>Redirecting...
|
||||
<body onload="document.getElementById('form').submit()">
|
||||
<form id="form" method="post" action="@{dest}">
|
||||
<noscript>
|
||||
<p>Javascript has been disabled; please click on the button below to be redirected.
|
||||
<input type="submit" value="Continue">
|
||||
|] >>= sendResponse
|
||||
|
||||
yesodVersion :: String
|
||||
yesodVersion = showVersion Paths_yesod_core.version
|
||||
|
||||
yesodRender :: (Yesod y, YesodSite y)
|
||||
=> y
|
||||
-> Route y
|
||||
-> [(String, String)]
|
||||
-> String
|
||||
yesodRender y u qs =
|
||||
S8.unpack $ fromMaybe
|
||||
(joinPath y (approot y) ps $ qs ++ qs')
|
||||
(urlRenderOverride y u)
|
||||
where
|
||||
(ps, qs') = formatPathSegments (getSite' y) u
|
||||
|
||||
@ -70,7 +70,7 @@ import System.Random (randomR, newStdGen)
|
||||
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import Control.Applicative ((<$>))
|
||||
import Control.Applicative ((<$>), (<*>))
|
||||
import Data.Enumerator (($$), run_, Iteratee)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
|
||||
@ -144,7 +144,8 @@ mkYesodGeneral name args clazzes isSub res = do
|
||||
let name' = mkName name
|
||||
args' = map mkName args
|
||||
arg = foldl AppT (ConT name') $ map VarT args'
|
||||
th <- mapM (thResourceFromResource arg) res -- FIXME now we cannot have multi-nested subsites
|
||||
th' <- mapM (thResourceFromResource arg) res -- FIXME now we cannot have multi-nested subsites
|
||||
let th = map fst th'
|
||||
w' <- createRoutes th
|
||||
let routesName = mkName $ name ++ "Route"
|
||||
let w = DataD [] routesName [] w' [''Show, ''Read, ''Eq]
|
||||
@ -170,18 +171,58 @@ mkYesodGeneral name args clazzes isSub res = do
|
||||
if isSub
|
||||
then (clazzes, ConT ''YesodSubSite `AppT` arg `AppT` VarT (mkName "master"), "getSubSite")
|
||||
else ([], ConT ''YesodSite `AppT` arg, "getSite")
|
||||
subsiteClauses <- catMaybes <$> mapM sc th'
|
||||
nothing <- [|Nothing|]
|
||||
let otherMethods =
|
||||
if isSub
|
||||
then []
|
||||
else [ FunD (mkName "dispatchToSubsite")
|
||||
(subsiteClauses ++ [Clause [WildP, WildP, WildP] (NormalB nothing) []])
|
||||
]
|
||||
let y = InstanceD ctx ytyp
|
||||
[ FunD (mkName yfunc) [Clause [] (NormalB site') []]
|
||||
]
|
||||
$ FunD (mkName yfunc) [Clause [] (NormalB site') []]
|
||||
: otherMethods
|
||||
return ([w, x], [y])
|
||||
where
|
||||
sc ((constr, SubSite { ssPieces = pieces }), Just toSub) = do
|
||||
master <- newName "master"
|
||||
mkey <- newName "mkey"
|
||||
just <- [|Just|]
|
||||
(pat', tma', rest) <- mkPat' pieces $ just `AppE` (VarE $ mkName toSub)
|
||||
ds <- [|dispatchSubsite|]
|
||||
let body' = ds `AppE` VarE master `AppE` VarE mkey `AppE` rest
|
||||
fmap' <- [|(<$>)|]
|
||||
let body = InfixE (Just body') fmap' $ Just tma'
|
||||
return $ Just $ Clause
|
||||
[ VarP master
|
||||
, VarP mkey
|
||||
, pat'
|
||||
] (NormalB body) []
|
||||
sc _ = return Nothing
|
||||
mkPat' :: [Piece] -> Exp -> Q (Pat, Exp, Exp)
|
||||
mkPat' (MultiPiece _:_) _ = error "MultiPiece not allowed as part of a subsite"
|
||||
mkPat' (StaticPiece s:rest) tma = do
|
||||
(x, tma, rest') <- mkPat' rest tma
|
||||
let sp = LitP $ StringL s
|
||||
return (InfixP sp (mkName ":") x, tma, rest')
|
||||
mkPat' (SinglePiece s:rest) tma = do
|
||||
fsp <- [|either (const Nothing) Just . fromSinglePiece|]
|
||||
v <- newName $ "var" ++ s
|
||||
be <- [|(<*>)|]
|
||||
let tma' = InfixE (Just tma) be $ Just $ fsp `AppE` VarE v
|
||||
(x, tma'', rest) <- mkPat' rest tma'
|
||||
return (InfixP (VarP v) (mkName ":") x, tma'', rest)
|
||||
mkPat' [] parse = do
|
||||
rest <- newName "rest"
|
||||
return (VarP rest, parse, VarE rest)
|
||||
|
||||
isStatic :: Piece -> Bool
|
||||
isStatic StaticPiece{} = True
|
||||
isStatic _ = False
|
||||
|
||||
thResourceFromResource :: Type -> Resource -> Q THResource
|
||||
thResourceFromResource :: Type -> Resource -> Q (THResource, Maybe String)
|
||||
thResourceFromResource _ (Resource n ps atts)
|
||||
| all (all isUpper) atts = return (n, Simple ps atts)
|
||||
| all (all isUpper) atts = return ((n, Simple ps atts), Nothing)
|
||||
thResourceFromResource master (Resource n ps [stype, toSubArg])
|
||||
-- static route to subsite
|
||||
= do
|
||||
@ -201,14 +242,14 @@ thResourceFromResource master (Resource n ps [stype, toSubArg])
|
||||
dispatch' <- [|flip handleSite (error "Cannot use subsite render function")|]
|
||||
let dispatch = dispatch' `AppE` gss'
|
||||
tmg <- mkToMasterArg ps toSubArg
|
||||
return (n, SubSite
|
||||
return ((n, SubSite
|
||||
{ ssType = ConT ''Route `AppT` stype'
|
||||
, ssParse = parse
|
||||
, ssRender = render
|
||||
, ssDispatch = dispatch
|
||||
, ssToMasterArg = tmg
|
||||
, ssPieces = ps
|
||||
})
|
||||
}), Just toSubArg)
|
||||
|
||||
|
||||
thResourceFromResource _ (Resource n _ _) =
|
||||
@ -244,8 +285,6 @@ toWaiAppPlain a = do
|
||||
key' <- encryptKey a
|
||||
return $ toWaiApp' a key'
|
||||
|
||||
dispatchPieces _ _ _ = Nothing -- FIXME
|
||||
|
||||
toWaiApp' :: (Yesod y, YesodSite y)
|
||||
=> y
|
||||
-> Maybe Key
|
||||
@ -256,7 +295,7 @@ toWaiApp' y key' env = do
|
||||
"":x -> x
|
||||
x -> x
|
||||
liftIO $ print (W.pathInfo env, segments)
|
||||
case dispatchPieces y key' segments of
|
||||
case dispatchToSubsite y key' segments of
|
||||
Nothing ->
|
||||
case cleanPath y segments of
|
||||
Nothing -> normalDispatch y key' segments env
|
||||
|
||||
@ -10,6 +10,7 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE FunctionalDependencies #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
---------------------------------------------------------
|
||||
--
|
||||
-- Module : Yesod.Handler
|
||||
@ -43,6 +44,7 @@ module Yesod.Handler
|
||||
, redirect
|
||||
, redirectParams
|
||||
, redirectString
|
||||
, redirectToPost
|
||||
-- ** Errors
|
||||
, notFound
|
||||
, badMethod
|
||||
@ -78,6 +80,10 @@ module Yesod.Handler
|
||||
-- ** Messages
|
||||
, setMessage
|
||||
, getMessage
|
||||
-- * Helpers for specific content
|
||||
-- ** Hamlet
|
||||
, hamletToContent
|
||||
, hamletToRepHtml
|
||||
-- ** Misc
|
||||
, newIdent
|
||||
-- * Internal Yesod
|
||||
@ -734,3 +740,39 @@ newIdent = GHandler $ lift $ lift $ lift $ do
|
||||
let i' = ghsIdent x + 1
|
||||
put x { ghsIdent = i' }
|
||||
return $ "h" ++ show i'
|
||||
|
||||
-- | Redirect to a POST resource.
|
||||
--
|
||||
-- This is not technically a redirect; instead, it returns an HTML page with a
|
||||
-- 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 :: Route master -> GHandler sub master a
|
||||
redirectToPost dest = hamletToRepHtml
|
||||
#if GHC7
|
||||
[hamlet|
|
||||
#else
|
||||
[$hamlet|
|
||||
#endif
|
||||
\<!DOCTYPE html>
|
||||
|
||||
<html>
|
||||
<head>
|
||||
<title>Redirecting...
|
||||
<body onload="document.getElementById('form').submit()">
|
||||
<form id="form" method="post" action="@{dest}">
|
||||
<noscript>
|
||||
<p>Javascript has been disabled; please click on the button below to be redirected.
|
||||
<input type="submit" value="Continue">
|
||||
|] >>= sendResponse
|
||||
|
||||
-- | Converts the given Hamlet template into 'Content', which can be used in a
|
||||
-- Yesod 'Response'.
|
||||
hamletToContent :: Hamlet (Route master) -> GHandler sub master Content
|
||||
hamletToContent h = do
|
||||
render <- getUrlRenderParams
|
||||
return $ toContent $ h render
|
||||
|
||||
-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.
|
||||
hamletToRepHtml :: Hamlet (Route master) -> GHandler sub master RepHtml
|
||||
hamletToRepHtml = fmap RepHtml . hamletToContent
|
||||
|
||||
@ -33,10 +33,6 @@ module Yesod.Widget
|
||||
, addScriptEither
|
||||
-- * Utilities
|
||||
, extractBody
|
||||
-- * Helpers for specific content
|
||||
-- ** Hamlet
|
||||
, hamletToContent
|
||||
, hamletToRepHtml
|
||||
) where
|
||||
|
||||
import Data.Monoid
|
||||
@ -46,14 +42,11 @@ import Text.Hamlet
|
||||
import Text.Cassius
|
||||
import Text.Julius
|
||||
import Yesod.Handler
|
||||
( Route, GHandler, YesodSubRoute(..), toMasterHandlerMaybe, getYesod
|
||||
, getUrlRenderParams
|
||||
)
|
||||
(Route, GHandler, YesodSubRoute(..), toMasterHandlerMaybe, getYesod)
|
||||
import Control.Applicative (Applicative)
|
||||
import Control.Monad.IO.Class (MonadIO)
|
||||
import Control.Monad.Trans.Class (MonadTrans (lift))
|
||||
import Yesod.Internal
|
||||
import Yesod.Content (RepHtml (RepHtml), Content, toContent)
|
||||
import Control.Monad (liftM)
|
||||
|
||||
import Control.Monad.IO.Peel (MonadPeelIO)
|
||||
@ -204,16 +197,3 @@ data PageContent url = PageContent
|
||||
, pageHead :: Hamlet url
|
||||
, pageBody :: Hamlet url
|
||||
}
|
||||
|
||||
-- FIXME these ideally belong somewhere else, I'm just not sure where
|
||||
|
||||
-- | Converts the given Hamlet template into 'Content', which can be used in a
|
||||
-- Yesod 'Response'.
|
||||
hamletToContent :: Hamlet (Route master) -> GHandler sub master Content
|
||||
hamletToContent h = do
|
||||
render <- getUrlRenderParams
|
||||
return $ toContent $ h render
|
||||
|
||||
-- | Wraps the 'Content' generated by 'hamletToContent' in a 'RepHtml'.
|
||||
hamletToRepHtml :: Hamlet (Route master) -> GHandler sub master RepHtml
|
||||
hamletToRepHtml = fmap RepHtml . hamletToContent
|
||||
|
||||
Loading…
Reference in New Issue
Block a user