Merge pull request #1805 from AriFordsham/ari/subsites

Fix subsite-to-subsite dispatch

yesod-core/ChangeLog.md

@@ -1,5 +1,9 @@
 # ChangeLog for yesod-core
 
+## 1.6.24.3
+
+* Fix subsite-to-subsite dispatch [#1805](https://github.com/yesodweb/yesod/pull/1805)
+
 ## 1.6.24.2
 
 * No star is type [#1797](https://github.com/yesodweb/yesod/pull/1797)

yesod-core/src/Yesod/Core/Internal/TH.hs

@@ -4,6 +4,7 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE RankNTypes #-}
 module Yesod.Core.Internal.TH where
 
 import Prelude hiding (exp)
@@ -22,6 +23,7 @@ import Text.ParserCombinators.Parsec.Char (alphaNum, spaces, string, char)
 
 import Yesod.Routes.TH
 import Yesod.Routes.Parse
+import Yesod.Core.Content (ToTypedContent (..))
 import Yesod.Core.Types
 import Yesod.Core.Class.Dispatch
 import Yesod.Core.Internal.Run
@@ -167,18 +169,10 @@ mkYesodGeneral appCxt' namestr mtys isSub f resS = do
             ]
     return (dataDec, dispatchDec)
 
-mkMDS :: (Exp -> Q Exp) -> Q Exp -> MkDispatchSettings a site b
-mkMDS f rh = MkDispatchSettings
+mkMDS :: (Exp -> Q Exp) -> Q Exp -> Q Exp -> MkDispatchSettings a site b
+mkMDS f rh sd = MkDispatchSettings
     { mdsRunHandler = rh
-    , mdsSubDispatcher =
-        [|\parentRunner getSub toParent env -> yesodSubDispatch
-                                 YesodSubRunnerEnv
-                                    { ysreParentRunner = parentRunner
-                                    , ysreGetSub = getSub
-                                    , ysreToParentRoute = toParent
-                                    , ysreParentEnv = env
-                                    }
-                              |]
+    , mdsSubDispatcher = sd
     , mdsGetPathInfo = [|W.pathInfo|]
     , mdsSetPathInfo = [|\p r -> r { W.pathInfo = p }|]
     , mdsMethod = [|W.requestMethod|]
@@ -199,7 +193,20 @@ mkDispatchInstance :: Type                      -- ^ The master site type
                    -> [ResourceTree c]          -- ^ The resource
                    -> DecsQ
 mkDispatchInstance master cxt f res = do
-    clause' <- mkDispatchClause (mkMDS f [|yesodRunner|]) res
+    clause' <- 
+        mkDispatchClause 
+            (mkMDS 
+                f 
+                [|yesodRunner|] 
+                [|\parentRunner getSub toParent env -> yesodSubDispatch
+                    YesodSubRunnerEnv
+                    { ysreParentRunner = parentRunner
+                    , ysreGetSub = getSub
+                    , ysreToParentRoute = toParent
+                    , ysreParentEnv = env
+                    }
+                |])
+            res
     let thisDispatch = FunD 'yesodDispatch [clause']
     return [instanceD cxt yDispatch [thisDispatch]]
   where
@@ -207,7 +214,13 @@ mkDispatchInstance master cxt f res = do
 
 mkYesodSubDispatch :: [ResourceTree a] -> Q Exp
 mkYesodSubDispatch res = do
-    clause' <- mkDispatchClause (mkMDS return [|subHelper|]) res
+    clause' <- 
+        mkDispatchClause
+            (mkMDS 
+                return 
+                [|subHelper|] 
+                [|subTopDispatch|]) 
+        res
     inner <- newName "inner"
     let innerFun = FunD inner [clause']
     helper <- newName "helper"
@@ -218,6 +231,26 @@ mkYesodSubDispatch res = do
                     [innerFun]
                 ]
     return $ LetE [fun] (VarE helper)
+    
+subTopDispatch :: 
+    (YesodSubDispatch sub master) =>
+        (forall content. ToTypedContent content =>
+            SubHandlerFor child master content ->
+            YesodSubRunnerEnv child master ->
+            Maybe (Route child) ->
+            W.Application
+        ) ->
+        (mid -> sub) ->
+        (Route sub -> Route mid) ->
+        YesodSubRunnerEnv mid master ->
+        W.Application
+subTopDispatch _ getSub toParent env = yesodSubDispatch
+            (YesodSubRunnerEnv
+            { ysreParentRunner = ysreParentRunner env
+            , ysreGetSub = getSub . ysreGetSub env
+            , ysreToParentRoute = ysreToParentRoute env . toParent
+            , ysreParentEnv = ysreParentEnv env
+            })
 
 instanceD :: Cxt -> Type -> [Dec] -> Dec
 instanceD = InstanceD Nothing

yesod-core/test/YesodCoreTest.hs

@@ -9,6 +9,7 @@ import YesodCoreTest.Meta
 import YesodCoreTest.Links
 import YesodCoreTest.Header
 import YesodCoreTest.NoOverloadedStrings
+import YesodCoreTest.SubSub
 import YesodCoreTest.InternalRequest
 import YesodCoreTest.ErrorHandling
 import YesodCoreTest.Cache
@@ -43,6 +44,7 @@ specs = do
       mediaTest
       linksTest
       noOverloadedTest
+      subSubTest
       internalRequestTest
       errorHandlingTest
       cacheTest

yesod-core/test/YesodCoreTest/SubSub.hs

@@ -0,0 +1,50 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module YesodCoreTest.SubSub where
+
+import Test.Hspec
+
+import Yesod.Core
+import Network.Wai.Test
+import qualified Data.Text as T
+import qualified Data.ByteString.Lazy.Char8 as L8
+
+import YesodCoreTest.SubSubData
+
+data App = App { getOuter :: OuterSubSite }
+
+instance Yesod App
+
+getSubR :: SubHandlerFor InnerSubSite master T.Text
+getSubR = return $ T.pack "sub"
+
+instance YesodSubDispatch OuterSubSite master where
+  yesodSubDispatch = $(mkYesodSubDispatch resourcesOuterSubSite)
+
+instance YesodSubDispatch InnerSubSite master where
+  yesodSubDispatch = $(mkYesodSubDispatch resourcesInnerSubSite)
+
+mkYesod "App" [parseRoutes|
+/ OuterSubSiteR OuterSubSite getOuter
+|]
+
+app :: App
+app = App { getOuter = OuterSubSite { getInner = InnerSubSite }}
+
+runner :: Session () -> IO ()
+runner f = toWaiApp app >>= runSession f
+
+case_subSubsite :: IO ()
+case_subSubsite = runner $ do
+  res <- request defaultRequest
+  assertBody (L8.pack "sub") res
+  assertStatus 200 res
+
+subSubTest :: Spec
+subSubTest = describe "YesodCoreTest.SubSub" $ do
+  it "sub_subsite" case_subSubsite

yesod-core/test/YesodCoreTest/SubSubData.hs

@@ -0,0 +1,20 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module YesodCoreTest.SubSubData where
+
+import Yesod.Core
+
+
+data OuterSubSite = OuterSubSite { getInner :: InnerSubSite }
+
+data InnerSubSite = InnerSubSite
+
+mkYesodSubData "InnerSubSite" [parseRoutes|
+/ SubR GET
+|]
+
+mkYesodSubData "OuterSubSite" [parseRoutes|
+/ InnerSubSiteR InnerSubSite getInner
+|]

yesod-core/yesod-core.cabal

@@ -1,5 +1,5 @@
 name:            yesod-core
-version:         1.6.24.2
+version:         1.6.24.3
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -173,6 +173,8 @@ test-suite tests
                    YesodCoreTest.StubSslOnly
                    YesodCoreTest.StubStrictSameSite
                    YesodCoreTest.StubUnsecured
+                   YesodCoreTest.SubSub
+                   YesodCoreTest.SubSubData
                    YesodCoreTest.WaiSubsite
                    YesodCoreTest.Widget
                    YesodCoreTest.YesodTest