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

YesodSubDispatch

Browse Source
This commit is contained in:
Michael Snoyman 2013-03-13 08:48:28 +02:00
parent e928991410
commit 2aefef4414
8 changed files with 132 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -4,6 +4,7 @@ module Yesod.Core
( -- * Type classes
Yesod (..)
, YesodDispatch (..)
, YesodSubDispatch (..)
, RenderRoute (..)
-- ** Breadcrumbs
, YesodBreadcrumbs (..)

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

@ -1,13 +1,20 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
module Yesod.Core.Class.Dispatch where
import Yesod.Routes.Class
import qualified Network.Wai as W
import Yesod.Core.Types
import Yesod.Core.Content
import Yesod.Core.Class.Yesod
import Yesod.Core.Class.Handler
import Yesod.Core.Internal.Request (textQueryString)
import Yesod.Core.Internal.Run
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.
@ -20,3 +27,50 @@ class YesodDispatch sub master where
instance YesodDispatch WaiSubsite master where
yesodDispatch YesodRunnerEnv { yreSub = WaiSubsite app } req =
app req
class YesodSubDispatch sub m where
yesodSubDispatch
:: (HandlerError m, HandlerState m, master ~ HandlerMaster m, Yesod master, MonadBaseControl IO m)
=> (m TypedContent
-> YesodRunnerEnv master master
-> Maybe (Route master)
-> W.Application)
-> (master -> sub)
-> (Route sub -> Route master)
-> YesodRunnerEnv master master
-> W.Application
instance YesodSubDispatch WaiSubsite master where
yesodSubDispatch _ toSub _ YesodRunnerEnv { yreMaster = master } req =
app req
where
WaiSubsite app = toSub master
{-
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)
=> (m TypedContent
-> YesodRunnerEnv master master
-> Maybe (Route master)
-> W.Application)
-> (master -> sub)
-> (Route sub -> Route master)
-> HandlerT sub m TypedContent
-> YesodRunnerEnv master master
-> Maybe (Route sub)
-> W.Application
subHelper parentRunner getSub toMaster handlert env route =
parentRunner base env (fmap toMaster route)
where
base = stripHandlerT (fmap toTypedContent handlert) getSub toMaster route

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

@ -51,9 +51,11 @@ import Yesod.Routes.TH
import Yesod.Routes.Parse
import System.Log.FastLogger (Logger)
import Yesod.Core.Types
import Yesod.Core.Content
import Yesod.Core.Class.Yesod
import Yesod.Core.Class.Dispatch
import Yesod.Core.Internal.Run
import Yesod.Core.Class.Handler
-- | Generates URL datatype and site function for the given 'Resource's. This
-- is used for creating sites, /not/ subsites. See 'mkYesodSub' for the latter.
@ -117,13 +119,13 @@ mkYesodGeneral name args clazzes isSub resS = do
masterTypeSyns <- if isSub then return []
else sequence [handler, widget]
renderRouteDec <- mkRenderRouteInstance subsite res
dispatchDec <- mkDispatchInstance context sub master res
dispatchDec <- mkDispatchInstance context (if isSub then Just sub else Nothing) master res
return (renderRouteDec ++ masterTypeSyns, dispatchDec)
where sub = foldl appT subCons subArgs
master = if isSub then (varT $ mkName "master") else sub
context = if isSub then cxt $ yesod : map return clazzes
else return []
yesod = classP ''Yesod [master]
yesod = classP ''HandlerReader [master]
handler = tySynD (mkName "Handler") [] [t| GHandler $master $master |]
widget = tySynD (mkName "Widget") [] [t| GWidget $master $master () |]
res = map (fmap parseType) resS
@ -136,25 +138,65 @@ mkYesodGeneral name args clazzes isSub resS = do
-- when writing library/plugin for yesod, this combinator becomes
-- handy.
mkDispatchInstance :: CxtQ -- ^ The context
-> TypeQ -- ^ The subsite type
-> Maybe TypeQ -- ^ The subsite type
-> TypeQ -- ^ The master site type
-> [ResourceTree a] -- ^ The resource
-> DecsQ
mkDispatchInstance context sub master res = do
let yDispatch = conT ''YesodDispatch `appT` sub `appT` master
mkDispatchInstance context Nothing master res = do
let yDispatch = conT ''YesodDispatch `appT` master `appT` master
thisDispatch = do
clause' <- mkDispatchClause MkDispatchSettings
{ mdsRunHandler = [|yesodRunner|]
, mdsDispatcher = [|yesodDispatch |]
, mdsFixEnv = [|fixEnv|]
, mdsSubDispatcher = [|yesodSubDispatch|]
, mdsGetPathInfo = [|W.pathInfo|]
, mdsSetPathInfo = [|\p r -> r { W.pathInfo = p }|]
, mdsMethod = [|W.requestMethod|]
, mds404 = [|\env -> yesodRunner (notFound >> return ()) env Nothing|]
, mds405 = [|\env route -> yesodRunner (badMethod >> return ()) env (Just route)|]
, mds404 = [|notFound >> return ()|]
, mds405 = [|badMethod >> return ()|]
} res
return $ FunD 'yesodDispatch [clause']
in sequence [instanceD context yDispatch [thisDispatch]]
mkDispatchInstance context (Just sub) master res = do
yDispatch <- conT ''YesodSubDispatch `appT` sub `appT` master
parentRunner <- newName "parentRunner"
getSub <- newName "getSub"
toMaster <- newName "toMaster"
runner <- newName "runner"
clause' <- mkDispatchClause MkDispatchSettings
{ mdsRunHandler = [|subHelper
$(return $ VarE parentRunner)
$(return $ VarE getSub)
$(return $ VarE toMaster)
. fmap toTypedContent
|]
, mdsSubDispatcher = [|yesodSubDispatch|]
, mdsGetPathInfo = [|W.pathInfo|]
, mdsSetPathInfo = [|\p r -> r { W.pathInfo = p }|]
, mdsMethod = [|W.requestMethod|]
, mds404 = [|notFound >> return ()|]
, mds405 = [|badMethod >> return ()|]
} res
inner <- newName "inner"
err <- [|error "FIXME"|]
let innerFun = FunD inner [clause']
runnerFun = FunD runner
[ Clause
[]
(NormalB $ VarE 'subHelper
`AppE` VarE parentRunner
`AppE` VarE getSub
`AppE` VarE toMaster
)
[]
]
context' <- context
let fun = FunD 'yesodSubDispatch
[ Clause
[VarP parentRunner, VarP getSub, VarP toMaster]
(NormalB $ VarE inner)
[innerFun, runnerFun]
]
return [InstanceD context' yDispatch [fun]]
-- | Convert the given argument into a WAI application, executable with any WAI
-- handler. This is the same as 'toWaiAppPlain', except it includes two

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

@ -284,7 +284,7 @@ fixEnv toNewSub toOldRoute envOld =
, yreToMaster = yreToMaster envOld . toOldRoute
}
stripHandlerT :: (HandlerReader m, HandlerState m, MonadBaseControl IO m)
stripHandlerT :: (HandlerState m, MonadBaseControl IO m)
=> HandlerT sub m a
-> (HandlerMaster m -> sub)
-> (Route sub -> Route (HandlerMaster m))

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

@ -13,6 +13,7 @@ import Control.Arrow (first)
import Control.Exception (Exception, throwIO)
import Control.Failure (Failure (..))
import Control.Monad (liftM)
import Control.Monad.Trans.Class (MonadTrans)
import Control.Monad.Base (MonadBase (liftBase))
import Control.Monad.IO.Class (MonadIO (liftIO))
import Control.Monad.Logger (LogLevel, LogSource,
@ -201,6 +202,13 @@ newtype HandlerT sub m a = HandlerT
{ unHandlerT :: HandlerData sub sub -> m a
}
instance MonadTrans (HandlerT sub)
instance Monad m => Monad (HandlerT sub m) where
return = HandlerT . const . return
HandlerT f >>= g = HandlerT $ \hd -> f hd >>= \x -> unHandlerT (g x) hd
instance Monad m => Functor (HandlerT sub m) where
fmap = liftM
data GHState = GHState
{ ghsSession :: SessionMap
, ghsRBC :: Maybe RequestBodyContents

4
yesod-core/test/YesodCoreTest/CleanPath.hs
View File

@ -29,8 +29,8 @@ instance RenderRoute Subsite where
deriving (Eq, Show, Read)
renderRoute (SubsiteRoute x) = (x, [])
instance YesodDispatch Subsite master where
yesodDispatch _getEnv req = return $ responseLBS
instance YesodSubDispatch Subsite master where
yesodSubDispatch _ _ _ _ req = return $ responseLBS
status200
[ ("Content-Type", "SUBSITE")
] $ L8.pack $ show (pathInfo req)

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

@ -51,8 +51,8 @@ case_subsite = runner $ do
res <- request defaultRequest
{ pathInfo = map T.pack ["subsite", "bar"]
}
assertStatus 200 res
assertBody (L8.pack "BarR") res
assertStatus 200 res
noOverloadedTest :: Spec
noOverloadedTest = describe "Test.NoOverloadedStrings" $ do

25
yesod-routes/Yesod/Routes/TH/Dispatch.hs
View File

@ -31,8 +31,7 @@ flatten =
data MkDispatchSettings = MkDispatchSettings
{ mdsRunHandler :: Q Exp
, mdsDispatcher :: Q Exp
, mdsFixEnv :: Q Exp
, mdsSubDispatcher :: Q Exp
, mdsGetPathInfo :: Q Exp
, mdsSetPathInfo :: Q Exp
, mdsMethod :: Q Exp
@ -145,7 +144,11 @@ mkDispatchClause mds ress' = do
u <- [|case $(return dispatched) of
Just f -> f $(return $ VarE getEnv0)
$(return $ VarE req0)
Nothing -> $(mds404 mds) $(return $ VarE getEnv0) $(return $ VarE req0)
Nothing -> $(mdsRunHandler mds)
$(mds404 mds)
$(return $ VarE getEnv0)
Nothing
$(return $ VarE req0)
|]
return $ Clause pats (NormalB u) $ dispatchFun : methodMaps
where
@ -323,9 +326,10 @@ buildCaller mds xrest parents name resDisp ys = do
f <- newName "f"
let apply = foldl' (\a b -> a `AppE` VarE b) (VarE f) ys
body405 <-
[|$(mds405 mds)
[|$(mdsRunHandler mds)
$(mds405 mds)
$(return $ VarE getEnv)
$(return route)
(Just $(return route))
$(return $ VarE req)
|]
return $ CaseE mf
@ -337,12 +341,11 @@ buildCaller mds xrest parents name resDisp ys = do
sub <- newName "sub"
let sub2 = LamE [VarP sub]
(foldl' (\a b -> a `AppE` VarE b) (VarE (mkName getSub) `AppE` VarE sub) ys)
[|$(mdsDispatcher mds)
($(mdsFixEnv mds)
$(return sub2)
$(return route)
$(return $ VarE getEnv)
)
[|$(mdsSubDispatcher mds)
$(mdsRunHandler mds)
$(return sub2)
$(return route)
$(return $ VarE getEnv)
($(mdsSetPathInfo mds)
$(return $ VarE xrest)
$(return $ VarE req)