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

Beginning of modifications to dispatch code for more powerful subsites

Browse Source
This commit is contained in:
Michael Snoyman 2011-01-26 00:21:32 +02:00
parent fddfd9bcf1
commit ee3fc92111
4 changed files with 113 additions and 79 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

67
Yesod/Core.hs
View File

@ -17,7 +17,6 @@ module Yesod.Core
-- * Utitlities -- * Utitlities
, maybeAuthorized , maybeAuthorized
, widgetToPageContent , widgetToPageContent
, redirectToPost
-- * Defaults -- * Defaults
, defaultErrorHandler , defaultErrorHandler
-- * Data types -- * Data types
@ -46,6 +45,7 @@ import qualified Web.ClientSession as CS
import qualified Data.ByteString as S import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy.Char8 as L8
import Data.Monoid import Data.Monoid
import Control.Monad.Trans.Writer import Control.Monad.Trans.Writer
import Control.Monad.Trans.State hiding (get, put) import Control.Monad.Trans.State hiding (get, put)
@ -77,10 +77,7 @@ import qualified Data.Text.Encoding
#define HAMLET $hamlet #define HAMLET $hamlet
#endif #endif
{- FIXME -- FIXME ditch the whole Site thing and just have render and dispatch?
class YesodDispatcher y where
dispatchSubsite :: y -> Key -> [String] -> Maybe Application
-}
-- | This class is automatically instantiated when you use the template haskell -- | This class is automatically instantiated when you use the template haskell
-- mkYesod function. You should never need to deal with it directly. -- mkYesod function. You should never need to deal with it directly.
@ -88,6 +85,7 @@ class Eq (Route y) => YesodSite y where
getSite :: Site (Route y) (Method -> Maybe (GHandler y y ChooseRep)) getSite :: Site (Route y) (Method -> Maybe (GHandler y y ChooseRep))
getSite' :: y -> Site (Route y) (Method -> Maybe (GHandler y y ChooseRep)) getSite' :: y -> Site (Route y) (Method -> Maybe (GHandler y y ChooseRep))
getSite' _ = getSite getSite' _ = getSite
dispatchToSubsite :: y -> Maybe CS.Key -> [String] -> Maybe W.Application
type Method = String type Method = String
@ -95,6 +93,8 @@ type Method = String
-- to deal with it directly, as mkYesodSub creates instances appropriately. -- to deal with it directly, as mkYesodSub creates instances appropriately.
class Eq (Route s) => YesodSubSite s y where class Eq (Route s) => YesodSubSite s y where
getSubSite :: Site (Route s) (Method -> Maybe (GHandler s y ChooseRep)) 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 -- | Define settings for a Yesod applications. The only required setting is
-- 'approot'; other than that, there are intelligent defaults. -- '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 -- Return 'Nothing' is the request is authorized, 'Just' a message if
-- unauthorized. If authentication is required, you should use a redirect; -- unauthorized. If authentication is required, you should use a redirect;
-- the Auth helper provides this functionality automatically. -- the Auth helper provides this functionality automatically.
--
-- FIXME make this a part of the Yesod middlewares
isAuthorized :: Route a isAuthorized :: Route a
-> Bool -- ^ is this a write request? -> Bool -- ^ is this a write request?
-> GHandler s a AuthResult -> GHandler s a AuthResult
@ -485,6 +483,21 @@ $maybe j <- jscript
|] |]
return $ PageContent title head'' body 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 #if TEST
coreTestSuite :: Test coreTestSuite :: Test
coreTestSuite = testGroup "Yesod.Yesod" coreTestSuite = testGroup "Yesod.Yesod"
@ -535,43 +548,3 @@ caseUtf8JoinPath :: Assertion
caseUtf8JoinPath = do caseUtf8JoinPath = do
"/%D7%A9%D7%9C%D7%95%D7%9D/" @=? joinPath TmpYesod "" ["שלום"] [] "/%D7%A9%D7%9C%D7%95%D7%9D/" @=? joinPath TmpYesod "" ["שלום"] []
#endif #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

61
Yesod/Dispatch.hs
View File

@ -70,7 +70,7 @@ import System.Random (randomR, newStdGen)
import qualified Data.Map as Map import qualified Data.Map as Map
import Control.Applicative ((<$>)) import Control.Applicative ((<$>), (<*>))
import Data.Enumerator (($$), run_, Iteratee) import Data.Enumerator (($$), run_, Iteratee)
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
@ -144,7 +144,8 @@ mkYesodGeneral name args clazzes isSub res = do
let name' = mkName name let name' = mkName name
args' = map mkName args args' = map mkName args
arg = foldl AppT (ConT name') $ map VarT 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 w' <- createRoutes th
let routesName = mkName $ name ++ "Route" let routesName = mkName $ name ++ "Route"
let w = DataD [] routesName [] w' [''Show, ''Read, ''Eq] let w = DataD [] routesName [] w' [''Show, ''Read, ''Eq]
@ -170,18 +171,58 @@ mkYesodGeneral name args clazzes isSub res = do
if isSub if isSub
then (clazzes, ConT ''YesodSubSite `AppT` arg `AppT` VarT (mkName "master"), "getSubSite") then (clazzes, ConT ''YesodSubSite `AppT` arg `AppT` VarT (mkName "master"), "getSubSite")
else ([], ConT ''YesodSite `AppT` arg, "getSite") 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 let y = InstanceD ctx ytyp
[ FunD (mkName yfunc) [Clause [] (NormalB site') []] $ FunD (mkName yfunc) [Clause [] (NormalB site') []]
] : otherMethods
return ([w, x], [y]) 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 :: Piece -> Bool
isStatic StaticPiece{} = True isStatic StaticPiece{} = True
isStatic _ = False isStatic _ = False
thResourceFromResource :: Type -> Resource -> Q THResource thResourceFromResource :: Type -> Resource -> Q (THResource, Maybe String)
thResourceFromResource _ (Resource n ps atts) 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]) thResourceFromResource master (Resource n ps [stype, toSubArg])
-- static route to subsite -- static route to subsite
= do = do
@ -201,14 +242,14 @@ thResourceFromResource master (Resource n ps [stype, toSubArg])
dispatch' <- [|flip handleSite (error "Cannot use subsite render function")|] dispatch' <- [|flip handleSite (error "Cannot use subsite render function")|]
let dispatch = dispatch' `AppE` gss' let dispatch = dispatch' `AppE` gss'
tmg <- mkToMasterArg ps toSubArg tmg <- mkToMasterArg ps toSubArg
return (n, SubSite return ((n, SubSite
{ ssType = ConT ''Route `AppT` stype' { ssType = ConT ''Route `AppT` stype'
, ssParse = parse , ssParse = parse
, ssRender = render , ssRender = render
, ssDispatch = dispatch , ssDispatch = dispatch
, ssToMasterArg = tmg , ssToMasterArg = tmg
, ssPieces = ps , ssPieces = ps
}) }), Just toSubArg)
thResourceFromResource _ (Resource n _ _) = thResourceFromResource _ (Resource n _ _) =
@ -244,8 +285,6 @@ toWaiAppPlain a = do
key' <- encryptKey a key' <- encryptKey a
return $ toWaiApp' a key' return $ toWaiApp' a key'
dispatchPieces _ _ _ = Nothing -- FIXME
toWaiApp' :: (Yesod y, YesodSite y) toWaiApp' :: (Yesod y, YesodSite y)
=> y => y
-> Maybe Key -> Maybe Key
@ -256,7 +295,7 @@ toWaiApp' y key' env = do
"":x -> x "":x -> x
x -> x x -> x
liftIO $ print (W.pathInfo env, segments) liftIO $ print (W.pathInfo env, segments)
case dispatchPieces y key' segments of case dispatchToSubsite y key' segments of
Nothing -> Nothing ->
case cleanPath y segments of case cleanPath y segments of
Nothing -> normalDispatch y key' segments env Nothing -> normalDispatch y key' segments env

42
Yesod/Handler.hs
View File

@ -10,6 +10,7 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
--------------------------------------------------------- ---------------------------------------------------------
-- --
-- Module : Yesod.Handler -- Module : Yesod.Handler
@ -43,6 +44,7 @@ module Yesod.Handler
, redirect , redirect
, redirectParams , redirectParams
, redirectString , redirectString
, redirectToPost
-- ** Errors -- ** Errors
, notFound , notFound
, badMethod , badMethod
@ -78,6 +80,10 @@ module Yesod.Handler
-- ** Messages -- ** Messages
, setMessage , setMessage
, getMessage , getMessage
-- * Helpers for specific content
-- ** Hamlet
, hamletToContent
, hamletToRepHtml
-- ** Misc -- ** Misc
, newIdent , newIdent
-- * Internal Yesod -- * Internal Yesod
@ -734,3 +740,39 @@ newIdent = GHandler $ lift $ lift $ lift $ do
let i' = ghsIdent x + 1 let i' = ghsIdent x + 1
put x { ghsIdent = i' } put x { ghsIdent = i' }
return $ "h" ++ show 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

22
Yesod/Widget.hs
View File

@ -33,10 +33,6 @@ module Yesod.Widget
, addScriptEither , addScriptEither
-- * Utilities -- * Utilities
, extractBody , extractBody
-- * Helpers for specific content
-- ** Hamlet
, hamletToContent
, hamletToRepHtml
) where ) where
import Data.Monoid import Data.Monoid
@ -46,14 +42,11 @@ import Text.Hamlet
import Text.Cassius import Text.Cassius
import Text.Julius import Text.Julius
import Yesod.Handler import Yesod.Handler
( Route, GHandler, YesodSubRoute(..), toMasterHandlerMaybe, getYesod (Route, GHandler, YesodSubRoute(..), toMasterHandlerMaybe, getYesod)
, getUrlRenderParams
)
import Control.Applicative (Applicative) import Control.Applicative (Applicative)
import Control.Monad.IO.Class (MonadIO) import Control.Monad.IO.Class (MonadIO)
import Control.Monad.Trans.Class (MonadTrans (lift)) import Control.Monad.Trans.Class (MonadTrans (lift))
import Yesod.Internal import Yesod.Internal
import Yesod.Content (RepHtml (RepHtml), Content, toContent)
import Control.Monad (liftM) import Control.Monad (liftM)
import Control.Monad.IO.Peel (MonadPeelIO) import Control.Monad.IO.Peel (MonadPeelIO)
@ -204,16 +197,3 @@ data PageContent url = PageContent
, pageHead :: Hamlet url , pageHead :: Hamlet url
, pageBody :: 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