From 97b07380e530820dd404cc19abe8b52b6b56a573 Mon Sep 17 00:00:00 2001 From: Ari Fordsham Date: Sun, 25 Jun 2023 16:30:17 +0300 Subject: [PATCH 1/5] Make changes --- yesod-core/src/Yesod/Core/Internal/TH.hs | 44 +++++++++++++++++------- 1 file changed, 31 insertions(+), 13 deletions(-) diff --git a/yesod-core/src/Yesod/Core/Internal/TH.hs b/yesod-core/src/Yesod/Core/Internal/TH.hs index 11bbf90b..1bbcbbb1 100644 --- a/yesod-core/src/Yesod/Core/Internal/TH.hs +++ b/yesod-core/src/Yesod/Core/Internal/TH.hs @@ -167,18 +167,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 +191,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 +212,20 @@ 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|] + [|\_ getSub toParent env -> yesodSubDispatch + YesodSubRunnerEnv + { ysreParentRunner = ysreParentRunner env + , ysreGetSub = getSub . ysreGetSub env + , ysreToParentRoute = ysreToParentRoute env . toParent + , ysreParentEnv = ysreParentEnv env + } + |]) + res inner <- newName "inner" let innerFun = FunD inner [clause'] helper <- newName "helper" From b0634b0d45498f73a522d8e301cedb16386c6ecd Mon Sep 17 00:00:00 2001 From: Ari Fordsham Date: Sun, 25 Jun 2023 17:43:13 +0300 Subject: [PATCH 2/5] Works with subsite-with-static --- yesod-core/src/Yesod/Core/Internal/TH.hs | 31 ++++++++++++++++++------ yesod-core/yesod-core.cabal | 2 +- 2 files changed, 24 insertions(+), 9 deletions(-) diff --git a/yesod-core/src/Yesod/Core/Internal/TH.hs b/yesod-core/src/Yesod/Core/Internal/TH.hs index 1bbcbbb1..27756688 100644 --- a/yesod-core/src/Yesod/Core/Internal/TH.hs +++ b/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 @@ -217,14 +219,7 @@ mkYesodSubDispatch res = do (mkMDS return [|subHelper|] - [|\_ getSub toParent env -> yesodSubDispatch - YesodSubRunnerEnv - { ysreParentRunner = ysreParentRunner env - , ysreGetSub = getSub . ysreGetSub env - , ysreToParentRoute = ysreToParentRoute env . toParent - , ysreParentEnv = ysreParentEnv env - } - |]) + [|subTopDispatch|]) res inner <- newName "inner" let innerFun = FunD inner [clause'] @@ -236,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 diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index 4aa6b021..c1deb3c0 100644 --- a/yesod-core/yesod-core.cabal +++ b/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 From 8be44a8cf4f755a90de64cb61fe22eb3570d8915 Mon Sep 17 00:00:00 2001 From: Ari Fordsham Date: Sun, 25 Jun 2023 18:10:53 +0300 Subject: [PATCH 3/5] Add changelog --- yesod-core/ChangeLog.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/yesod-core/ChangeLog.md b/yesod-core/ChangeLog.md index ced20414..0e903df3 100644 --- a/yesod-core/ChangeLog.md +++ b/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) From 9ce822b8f7c1780ecdc61c8234bb39d236b8ca48 Mon Sep 17 00:00:00 2001 From: Ari Fordsham Date: Sun, 9 Jul 2023 16:05:01 +0300 Subject: [PATCH 5/5] SubSubTest --- yesod-core/test/YesodCoreTest.hs | 2 + yesod-core/test/YesodCoreTest/SubSub.hs | 48 +++++++++++++++++++++ yesod-core/test/YesodCoreTest/SubSubData.hs | 20 +++++++++ yesod-core/yesod-core.cabal | 2 + 4 files changed, 72 insertions(+) create mode 100644 yesod-core/test/YesodCoreTest/SubSub.hs create mode 100644 yesod-core/test/YesodCoreTest/SubSubData.hs diff --git a/yesod-core/test/YesodCoreTest.hs b/yesod-core/test/YesodCoreTest.hs index 8f2b96dc..dc83b760 100644 --- a/yesod-core/test/YesodCoreTest.hs +++ b/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 diff --git a/yesod-core/test/YesodCoreTest/SubSub.hs b/yesod-core/test/YesodCoreTest/SubSub.hs new file mode 100644 index 00000000..e38ea412 --- /dev/null +++ b/yesod-core/test/YesodCoreTest/SubSub.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +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 \ No newline at end of file diff --git a/yesod-core/test/YesodCoreTest/SubSubData.hs b/yesod-core/test/YesodCoreTest/SubSubData.hs new file mode 100644 index 00000000..636da3a5 --- /dev/null +++ b/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 +|] \ No newline at end of file diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index 4aa6b021..e139241c 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -173,6 +173,8 @@ test-suite tests YesodCoreTest.StubSslOnly YesodCoreTest.StubStrictSameSite YesodCoreTest.StubUnsecured + YesodCoreTest.SubSub + YesodCoreTest.SubSubData YesodCoreTest.WaiSubsite YesodCoreTest.Widget YesodCoreTest.YesodTest