yesod-core 1.6.24.2 → 1.6.24.3
raw patch · 6 files changed
+125/−14 lines, 6 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- ChangeLog.md +4/−0
- src/Yesod/Core/Internal/TH.hs +46/−13
- test/YesodCoreTest.hs +2/−0
- test/YesodCoreTest/SubSub.hs +50/−0
- test/YesodCoreTest/SubSubData.hs +20/−0
- yesod-core.cabal +3/−1
ChangeLog.md view
@@ -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)
src/Yesod/Core/Internal/TH.hs view
@@ -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 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 @@ ] 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 @@ -> [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 @@ 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 @@ [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
test/YesodCoreTest.hs view
@@ -9,6 +9,7 @@ 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 @@ mediaTest linksTest noOverloadedTest+ subSubTest internalRequestTest errorHandlingTest cacheTest
+ test/YesodCoreTest/SubSub.hs view
@@ -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
+ test/YesodCoreTest/SubSubData.hs view
@@ -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.cabal view
@@ -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 @@ YesodCoreTest.StubSslOnly YesodCoreTest.StubStrictSameSite YesodCoreTest.StubUnsecured+ YesodCoreTest.SubSub+ YesodCoreTest.SubSubData YesodCoreTest.WaiSubsite YesodCoreTest.Widget YesodCoreTest.YesodTest