YesodSubDispatch

yesod-core/Yesod/Core.hs

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

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

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
+mkDispatchInstance context Nothing master res = do
-  let yDispatch = conT ''YesodDispatch `appT` sub `appT` master
+  let yDispatch = conT ''YesodDispatch `appT` master `appT` master
       thisDispatch = do
             clause' <- mkDispatchClause MkDispatchSettings
                 { mdsRunHandler = [|yesodRunner|]
-                , mdsDispatcher = [|yesodDispatch |]
+                , mdsSubDispatcher = [|yesodSubDispatch|]
-                , mdsFixEnv = [|fixEnv|]
                 , mdsGetPathInfo = [|W.pathInfo|]
                 , mdsSetPathInfo = [|\p r -> r { W.pathInfo = p }|]
                 , mdsMethod = [|W.requestMethod|]
-                , mds404 = [|\env -> yesodRunner (notFound >> return ()) env Nothing|]
+                , mds404 = [|notFound >> return ()|]
-                , mds405 = [|\env route -> yesodRunner (badMethod >> return ()) env (Just route)|]
+                , 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

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))

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

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
+instance YesodSubDispatch Subsite master where
-    yesodDispatch _getEnv req = return $ responseLBS
+    yesodSubDispatch _ _ _ _ req = return $ responseLBS
         status200
         [ ("Content-Type", "SUBSITE")
         ] $ L8.pack $ show (pathInfo req)

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

yesod-routes/Yesod/Routes/TH/Dispatch.hs

@@ -31,8 +31,7 @@ flatten =
 
 data MkDispatchSettings = MkDispatchSettings
     { mdsRunHandler :: Q Exp
-    , mdsDispatcher :: Q Exp
+    , mdsSubDispatcher :: Q Exp
-    , mdsFixEnv :: 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)
+                [|$(mdsSubDispatcher mds)
-                    ($(mdsFixEnv mds)
+                    $(mdsRunHandler mds)
-                        $(return sub2)
+                    $(return sub2)
-                        $(return route)
+                    $(return route)
-                        $(return $ VarE getEnv)
+                    $(return $ VarE getEnv)
-                        )
                     ($(mdsSetPathInfo mds)
                         $(return $ VarE xrest)
                         $(return $ VarE req)