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

Steps towards unifying on YesodDispatch

Browse Source
This commit is contained in:
Michael Snoyman 2011-01-28 10:30:02 +02:00
parent c87068b7fb
commit 09e93e96a1
4 changed files with 67 additions and 52 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

41
Yesod/Core.hs
View File

@ -80,11 +80,17 @@ import qualified Data.Text.Encoding
class Eq u => RenderRoute u where class Eq u => RenderRoute u where
renderRoute :: u -> ([String], [(String, String)]) renderRoute :: u -> ([String], [(String, String)])
-- FIXME unify YesodSite and YesodSubSite
-- | 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.
class RenderRoute (Route y) => YesodDispatch y where class Yesod master => YesodDispatch a master where
yesodDispatch :: y -> Maybe CS.Key -> [String] -> Maybe W.Application yesodDispatch
:: (Yesod master)
=> a
-> Maybe CS.Key
-> [String]
-> master
-> (Route a -> Route master)
-> Maybe W.Application
-- | Same as 'YesodSite', but for subsites. Once again, users should not need -- | Same as 'YesodSite', but for subsites. Once again, users should not need
-- to deal with it directly, as mkYesodSub creates instances appropriately. -- to deal with it directly, as mkYesodSub creates instances appropriately.
@ -246,22 +252,29 @@ class RenderRoute (Route a) => Yesod a where
sessionIpAddress :: a -> Bool sessionIpAddress :: a -> Bool
sessionIpAddress _ = True sessionIpAddress _ = True
yesodRunner :: a -> Maybe CS.Key -> Maybe (Route a) -> GHandler a a ChooseRep -> W.Application -- FIXME this probably needs to be a part of YesodDispatch
yesodRunner :: Yesod master
=> a
-> master
-> (Route a -> Route master)
-> Maybe CS.Key -> Maybe (Route a) -> GHandler a master ChooseRep -> W.Application
yesodRunner = defaultYesodRunner yesodRunner = defaultYesodRunner
defaultYesodRunner :: Yesod a defaultYesodRunner :: Yesod master
=> a => a
-> master
-> (Route a -> Route master)
-> Maybe CS.Key -> Maybe CS.Key
-> Maybe (Route a) -> Maybe (Route a)
-> GHandler a a ChooseRep -> GHandler a master ChooseRep
-> W.Application -> W.Application
defaultYesodRunner y mkey murl handler req = do defaultYesodRunner s master toMasterRoute mkey murl handler req = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
let getExpires m = fromIntegral (m * 60) `addUTCTime` now let getExpires m = fromIntegral (m * 60) `addUTCTime` now
let exp' = getExpires $ clientSessionDuration y let exp' = getExpires $ clientSessionDuration master
-- FIXME will show remoteHost give the answer I need? will it include port -- FIXME will show remoteHost give the answer I need? will it include port
-- information that changes on each request? -- information that changes on each request?
let host = if sessionIpAddress y then S8.pack (show (W.remoteHost req)) else "" let host = if sessionIpAddress master then S8.pack (show (W.remoteHost req)) else ""
let session' = let session' =
case mkey of case mkey of
Nothing -> [] Nothing -> []
@ -274,12 +287,12 @@ defaultYesodRunner y mkey murl handler req = do
case murl of case murl of
Nothing -> handler Nothing -> handler
Just url -> do Just url -> do
isWrite <- isWriteRequest url isWrite <- isWriteRequest $ toMasterRoute url
ar <- isAuthorized url isWrite ar <- isAuthorized (toMasterRoute url) isWrite
case ar of case ar of
Authorized -> return () Authorized -> return ()
AuthenticationRequired -> AuthenticationRequired ->
case authRoute y of case authRoute master of
Nothing -> Nothing ->
permissionDenied "Authentication required" permissionDenied "Authentication required"
Just url' -> do Just url' -> do
@ -289,7 +302,7 @@ defaultYesodRunner y mkey murl handler req = do
handler handler
let sessionMap = Map.fromList let sessionMap = Map.fromList
$ filter (\(x, _) -> x /= nonceKey) session' $ filter (\(x, _) -> x /= nonceKey) session'
yar <- handlerToYAR y (yesodRender y) errorHandler rr murl sessionMap h yar <- handlerToYAR master s toMasterRoute (yesodRender master) errorHandler rr murl sessionMap h
let mnonce = reqNonce rr let mnonce = reqNonce rr
return $ yarToResponse (hr mnonce getExpires host exp') yar return $ yarToResponse (hr mnonce getExpires host exp') yar
where where
@ -307,7 +320,7 @@ defaultYesodRunner y mkey murl handler req = do
case mkey of case mkey of
Nothing -> hs Nothing -> hs
Just _ -> AddCookie Just _ -> AddCookie
(clientSessionDuration y) (clientSessionDuration master)
sessionName sessionName
sessionVal sessionVal
: hs : hs

56
Yesod/Dispatch.hs
View File

@ -177,20 +177,10 @@ mkYesodGeneral name args clazzes isSub res = do
subsiteClauses <- catMaybes <$> mapM mkDispatchToSubsite th' subsiteClauses <- catMaybes <$> mapM mkDispatchToSubsite th'
let subSubsiteClauses = [] -- FIXME subSubsiteClauses let subSubsiteClauses = [] -- FIXME subSubsiteClauses
nothing <- [|Nothing|] nothing <- [|Nothing|]
dds <- [|defaultDispatchSubsite|]
let otherMethods =
if isSub
then [ FunD (mkName "dispatchSubsite") [Clause [] (NormalB dds) []]
, FunD (mkName "dispatchToSubSubsite")
(subSubsiteClauses ++ [Clause [WildP, WildP, WildP, WildP, WildP] (NormalB nothing) []])
]
else [ FunD (mkName "dispatchToSubsite")
(subsiteClauses ++ [Clause [WildP, WildP, WildP] (NormalB nothing) []])
]
let mkYSS = InstanceD clazzes (ConT ''YesodSubSite `AppT` arg `AppT` VarT (mkName "master")) let mkYSS = InstanceD clazzes (ConT ''YesodSubSite `AppT` arg `AppT` VarT (mkName "master"))
[ [
] ]
mkYS = InstanceD [] (ConT ''YesodDispatch `AppT` arg) [FunD (mkName "yesodDispatch") [yd]] mkYS = InstanceD [] (ConT ''YesodDispatch `AppT` arg `AppT` arg) [FunD (mkName "yesodDispatch") [yd]]
let y = if isSub then mkYSS else mkYS {-InstanceD ctx ytyp let y = if isSub then mkYSS else mkYS {-InstanceD ctx ytyp
$ FunD (mkName yfunc) [Clause [] (NormalB site') []] $ FunD (mkName yfunc) [Clause [] (NormalB site') []]
: otherMethods -} : otherMethods -}
@ -200,26 +190,28 @@ isSubSite ((_, SubSite{}), _) = True
isSubSite _ = False isSubSite _ = False
mkYesodDispatch' sortedRes = do mkYesodDispatch' sortedRes = do
sub <- newName "sub"
master <- newName "master" master <- newName "master"
mkey <- newName "mkey" mkey <- newName "mkey"
segments <- newName "segments" segments <- newName "segments"
toMasterRoute <- newName "toMasterRoute"
nothing <- [|Nothing|] nothing <- [|Nothing|]
body <- foldM (go master mkey segments) nothing sortedRes body <- foldM (go master sub toMasterRoute mkey segments) nothing sortedRes
return $ Clause return $ Clause
[VarP master, VarP mkey, VarP segments] [VarP master, VarP mkey, VarP segments, VarP sub, VarP toMasterRoute]
(NormalB body) (NormalB body)
[] []
where where
go master mkey segments onFail ((constr, SubSite { ssPieces = pieces }), Just toSub) = do go master sub toMasterRoute mkey segments onFail ((constr, SubSite { ssPieces = pieces }), Just toSub) = do
test <- mkSubsiteExp segments pieces id (master, mkey, constr, toSub) test <- mkSubsiteExp segments pieces id (master, sub, toMasterRoute, mkey, constr, toSub)
just <- [|Just|] just <- [|Just|]
app <- newName "app" app <- newName "app"
return $ CaseE test return $ CaseE test
[ Match (ConP (mkName "Nothing") []) (NormalB onFail) [] [ Match (ConP (mkName "Nothing") []) (NormalB onFail) []
, Match (ConP (mkName "Just") [VarP app]) (NormalB $ just `AppE` VarE app) [] , Match (ConP (mkName "Just") [VarP app]) (NormalB $ just `AppE` VarE app) []
] ]
go master mkey segments onFail ((constr, Simple pieces methods), Nothing) = do go master sub toMasterRoute mkey segments onFail ((constr, Simple pieces methods), Nothing) = do
test <- mkSimpleExp segments pieces id (master, mkey, constr, methods) test <- mkSimpleExp segments pieces id (master, sub, toMasterRoute, mkey, constr, methods)
just <- [|Just|] just <- [|Just|]
app <- newName "app" app <- newName "app"
return $ CaseE test return $ CaseE test
@ -227,7 +219,7 @@ mkYesodDispatch' sortedRes = do
, Match (ConP (mkName "Just") [VarP app]) (NormalB $ just `AppE` VarE app) [] , Match (ConP (mkName "Just") [VarP app]) (NormalB $ just `AppE` VarE app) []
] ]
mkSimpleExp segments [] frontVars (master, mkey, constr, methods) = do mkSimpleExp segments [] frontVars (master, sub, toMasterRoute, mkey, constr, methods) = do
just <- [|Just|] just <- [|Just|]
nothing <- [|Nothing|] nothing <- [|Nothing|]
onSuccess <- newName "onSuccess" onSuccess <- newName "onSuccess"
@ -239,7 +231,13 @@ mkSimpleExp segments [] frontVars (master, mkey, constr, methods) = do
cr <- [|fmap chooseRep|] cr <- [|fmap chooseRep|]
let url = foldl' AppE (ConE $ mkName constr) $ frontVars [] let url = foldl' AppE (ConE $ mkName constr) $ frontVars []
let runHandlerVars h = runHandler $ foldl' AppE (cr `AppE` (VarE $ mkName h)) $ frontVars [] let runHandlerVars h = runHandler $ foldl' AppE (cr `AppE` (VarE $ mkName h)) $ frontVars []
runHandler h = NormalB $ yr `AppE` VarE master `AppE` VarE mkey `AppE` (just `AppE` url) `AppE` h `AppE` VarE req runHandler h = NormalB $ yr `AppE` VarE sub
`AppE` VarE master
`AppE` VarE toMasterRoute
`AppE` VarE mkey
`AppE` (just `AppE` url)
`AppE` h
`AppE` VarE req
let match m = Match (LitP $ StringL m) (runHandlerVars $ map toLower m ++ constr) [] let match m = Match (LitP $ StringL m) (runHandlerVars $ map toLower m ++ constr) []
let clauses = let clauses =
case methods of case methods of
@ -295,7 +293,7 @@ mkSimpleExp segments (SinglePiece s:pieces) frontVars x = do
] ]
return exp return exp
mkSubsiteExp segments [] frontVars (master, mkey, constr, toSub) = do mkSubsiteExp segments [] frontVars (master, sub, toMasterRoute, mkey, constr, toSub) = do
ds <- [|dispatchSubsite|] ds <- [|dispatchSubsite|]
let con = foldl' AppE (ConE $ mkName constr) $ frontVars [] let con = foldl' AppE (ConE $ mkName constr) $ frontVars []
let s' = VarE (mkName toSub) `AppE` VarE master let s' = VarE (mkName toSub) `AppE` VarE master
@ -493,7 +491,7 @@ mkToMasterArg ps fname = do
-- handler. This is the same as 'toWaiAppPlain', except it includes three -- handler. This is the same as 'toWaiAppPlain', except it includes three
-- middlewares: GZIP compression, JSON-P and path cleaning. This is the -- middlewares: GZIP compression, JSON-P and path cleaning. This is the
-- recommended approach for most users. -- recommended approach for most users.
toWaiApp :: (Yesod y, YesodDispatch y) => y -> IO W.Application toWaiApp :: (Yesod y, YesodDispatch y y) => y -> IO W.Application
toWaiApp y = do toWaiApp y = do
a <- toWaiAppPlain y a <- toWaiAppPlain y
return $ gzip False return $ gzip False
@ -502,12 +500,12 @@ toWaiApp y = do
-- | Convert the given argument into a WAI application, executable with any WAI -- | Convert the given argument into a WAI application, executable with any WAI
-- handler. This differs from 'toWaiApp' in that it uses no middlewares. -- handler. This differs from 'toWaiApp' in that it uses no middlewares.
toWaiAppPlain :: (Yesod y, YesodDispatch y) => y -> IO W.Application toWaiAppPlain :: (Yesod y, YesodDispatch y y) => y -> IO W.Application
toWaiAppPlain a = do toWaiAppPlain a = do
key' <- encryptKey a key' <- encryptKey a
return $ toWaiApp' a key' return $ toWaiApp' a key'
toWaiApp' :: (Yesod y, YesodDispatch y) toWaiApp' :: (Yesod y, YesodDispatch y y)
=> y => y
-> Maybe Key -> Maybe Key
-> W.Application -> W.Application
@ -517,14 +515,14 @@ 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 yesodDispatch y key' segments of case yesodDispatch y key' segments y id of
Just app -> app env Just app -> app env
Nothing -> Nothing ->
case cleanPath y segments of case cleanPath y segments of
Nothing -> Nothing ->
case yesodDispatch y key' segments of case yesodDispatch y key' segments y id of
Just app -> app env Just app -> app env
Nothing -> yesodRunner y key' Nothing notFound env Nothing -> yesodRunner y y id key' Nothing notFound env
Just segments' -> Just segments' ->
let dest = joinPath y (approot y) segments' [] let dest = joinPath y (approot y) segments' []
dest' = dest' =
@ -540,19 +538,21 @@ toWaiApp' y key' env = do
, ("Location", dest') , ("Location", dest')
] "Redirecting" ] "Redirecting"
{-
defaultDispatchSubsite defaultDispatchSubsite
:: (Yesod m, YesodDispatch m, YesodSubSite s m) :: (Yesod m, YesodDispatch m, YesodSubSite s m)
=> m -> Maybe Key -> [String] => m -> Maybe Key -> [String]
-> (Route s -> Route m) -> (Route s -> Route m)
-> s -> s
-> W.Application -> W.Application
defaultDispatchSubsite y key' segments toMasterRoute s env = defaultDispatchSubsite y key' segments toMasterRoute s env = error "FIXME" {-
case dispatchToSubSubsite y key' segments toMasterRoute s of case dispatchToSubSubsite y key' segments toMasterRoute s of
Just app -> app env Just app -> app env
Nothing -> Nothing ->
case dispatchSubLocal y key' segments toMasterRoute s of case dispatchSubLocal y key' segments toMasterRoute s of
Just app -> app env Just app -> app env
Nothing -> yesodRunner y key' Nothing notFound env Nothing -> yesodRunner y key' Nothing notFound env-}
-}
#if TEST #if TEST

20
Yesod/Handler.hs
View File

@ -345,16 +345,16 @@ runHandler :: HasReps c
-> Maybe (Route sub) -> Maybe (Route sub)
-> (Route sub -> Route master) -> (Route sub -> Route master)
-> master -> master
-> (master -> sub) -> sub
-> YesodApp -> YesodApp
runHandler handler mrender sroute tomr ma tosa = runHandler handler mrender sroute tomr ma sa =
YesodApp $ \eh rr cts initSession -> do YesodApp $ \eh rr cts initSession -> do
let toErrorHandler = let toErrorHandler =
InternalError InternalError
. (show :: Control.Exception.SomeException -> String) . (show :: Control.Exception.SomeException -> String)
let hd = HandlerData let hd = HandlerData
{ handlerRequest = rr { handlerRequest = rr
, handlerSub = tosa ma , handlerSub = sa
, handlerMaster = ma , handlerMaster = ma
, handlerRoute = sroute , handlerRoute = sroute
, handlerRender = mrender , handlerRender = mrender
@ -655,18 +655,20 @@ handlerTestSuite = testGroup "Yesod.Handler"
handlerToYAR :: (HasReps a, HasReps b) handlerToYAR :: (HasReps a, HasReps b)
=> m -- ^ master site foundation => m -- ^ master site foundation
-> s -- ^ sub site foundation
-> (Route s -> Route m)
-> (Route m -> [(String, String)] -> String) -- ^ url render -> (Route m -> [(String, String)] -> String) -- ^ url render
-> (ErrorResponse -> GHandler m m a) -> (ErrorResponse -> GHandler s m a)
-> Request -> Request
-> Maybe (Route m) -> Maybe (Route s)
-> SessionMap -> SessionMap
-> GHandler m m b -> GHandler s m b
-> Iteratee ByteString IO YesodAppResult -> Iteratee ByteString IO YesodAppResult
handlerToYAR y render errorHandler rr murl sessionMap h = handlerToYAR y s toMasterRoute render errorHandler rr murl sessionMap h =
unYesodApp ya eh' rr types sessionMap unYesodApp ya eh' rr types sessionMap
where where
ya = runHandler h render murl id y id ya = runHandler h render murl toMasterRoute y s
eh' er = runHandler (errorHandler' er) render murl id y id eh' er = runHandler (errorHandler' er) render murl toMasterRoute y s
types = httpAccept $ reqWaiRequest rr types = httpAccept $ reqWaiRequest rr
errorHandler' = localNoCurrent . errorHandler errorHandler' = localNoCurrent . errorHandler

2
helloworld.hs
View File

@ -26,6 +26,6 @@ mkYesod "HelloWorld" [$parseRoutes|
/subsite/#String SubsiteR Subsite getSubsite /subsite/#String SubsiteR Subsite getSubsite
|] |]
instance Yesod HelloWorld where approot _ = "" instance Yesod HelloWorld where approot _ = ""
getRootR :: GHandler HelloWorld HelloWorld RepPlain -- FIXME remove type sig -- getRootR :: GHandler HelloWorld HelloWorld RepPlain -- FIXME remove type sig
getRootR = return $ RepPlain "Hello World" getRootR = return $ RepPlain "Hello World"
main = toWaiApp (HelloWorld Subsite) >>= runEx print 3000 main = toWaiApp (HelloWorld Subsite) >>= runEx print 3000