From 2aefef441421ef30a748ff34026a6bebf2ab52a5 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 13 Mar 2013 08:48:28 +0200 Subject: [PATCH] YesodSubDispatch --- yesod-core/Yesod/Core.hs | 1 + yesod-core/Yesod/Core/Class/Dispatch.hs | 54 +++++++++++++++++ yesod-core/Yesod/Core/Dispatch.hs | 60 ++++++++++++++++--- yesod-core/Yesod/Core/Internal/Run.hs | 2 +- yesod-core/Yesod/Core/Types.hs | 8 +++ yesod-core/test/YesodCoreTest/CleanPath.hs | 4 +- .../test/YesodCoreTest/NoOverloadedStrings.hs | 2 +- yesod-routes/Yesod/Routes/TH/Dispatch.hs | 25 ++++---- 8 files changed, 132 insertions(+), 24 deletions(-) diff --git a/yesod-core/Yesod/Core.hs b/yesod-core/Yesod/Core.hs index 0fa8e489..c70bd0ff 100644 --- a/yesod-core/Yesod/Core.hs +++ b/yesod-core/Yesod/Core.hs @@ -4,6 +4,7 @@ module Yesod.Core ( -- * Type classes Yesod (..) , YesodDispatch (..) + , YesodSubDispatch (..) , RenderRoute (..) -- ** Breadcrumbs , YesodBreadcrumbs (..) diff --git a/yesod-core/Yesod/Core/Class/Dispatch.hs b/yesod-core/Yesod/Core/Class/Dispatch.hs index 11da629e..6783d9a9 100644 --- a/yesod-core/Yesod/Core/Class/Dispatch.hs +++ b/yesod-core/Yesod/Core/Class/Dispatch.hs @@ -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 diff --git a/yesod-core/Yesod/Core/Dispatch.hs b/yesod-core/Yesod/Core/Dispatch.hs index 07c60aaf..93eb9418 100644 --- a/yesod-core/Yesod/Core/Dispatch.hs +++ b/yesod-core/Yesod/Core/Dispatch.hs @@ -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 diff --git a/yesod-core/Yesod/Core/Internal/Run.hs b/yesod-core/Yesod/Core/Internal/Run.hs index e3cc9571..cb8bfdd7 100644 --- a/yesod-core/Yesod/Core/Internal/Run.hs +++ b/yesod-core/Yesod/Core/Internal/Run.hs @@ -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)) diff --git a/yesod-core/Yesod/Core/Types.hs b/yesod-core/Yesod/Core/Types.hs index a4f6f7a5..eae78512 100644 --- a/yesod-core/Yesod/Core/Types.hs +++ b/yesod-core/Yesod/Core/Types.hs @@ -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 diff --git a/yesod-core/test/YesodCoreTest/CleanPath.hs b/yesod-core/test/YesodCoreTest/CleanPath.hs index 8bf7f5a3..d344f24f 100644 --- a/yesod-core/test/YesodCoreTest/CleanPath.hs +++ b/yesod-core/test/YesodCoreTest/CleanPath.hs @@ -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) diff --git a/yesod-core/test/YesodCoreTest/NoOverloadedStrings.hs b/yesod-core/test/YesodCoreTest/NoOverloadedStrings.hs index db20541b..244276a2 100644 --- a/yesod-core/test/YesodCoreTest/NoOverloadedStrings.hs +++ b/yesod-core/test/YesodCoreTest/NoOverloadedStrings.hs @@ -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 diff --git a/yesod-routes/Yesod/Routes/TH/Dispatch.hs b/yesod-routes/Yesod/Routes/TH/Dispatch.hs index d4427954..d62affaa 100644 --- a/yesod-routes/Yesod/Routes/TH/Dispatch.hs +++ b/yesod-routes/Yesod/Routes/TH/Dispatch.hs @@ -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)