haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge pull request #1145 from ajnsit/hierarchical-subsites-args

Browse Source 
Pass hierarchical route arguments to subsites
This commit is contained in:
Michael Snoyman 2016-04-12 07:27:47 +03:00
commit 210f846af5
2 changed files with 19 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
yesod-core/Yesod/Routes/TH/Dispatch.hs
View File

@ -176,9 +176,10 @@ mkDispatchClause MkDispatchSettings {..} resources = do
subDispatcherE <- mdsSubDispatcher subDispatcherE <- mdsSubDispatcher
runHandlerE <- mdsRunHandler runHandlerE <- mdsRunHandler
sub <- newName "sub" sub <- newName "sub"
let allDyns = extraParams ++ dyns
sroute <- newName "sroute" sroute <- newName "sroute"
let sub2 = LamE [VarP sub] let sub2 = LamE [VarP sub]
(foldl' (\a b -> a `AppE` b) (VarE (mkName getSub) `AppE` VarE sub) dyns) (foldl' (\a b -> a `AppE` b) (VarE (mkName getSub) `AppE` VarE sub) allDyns)
let reqExp' = setPathInfoE `AppE` VarE restPath `AppE` reqExp let reqExp' = setPathInfoE `AppE` VarE restPath `AppE` reqExp
route' = foldl' AppE (ConE (mkName name)) dyns route' = foldl' AppE (ConE (mkName name)) dyns
route = LamE [VarP sroute] $ foldr AppE (AppE route' $ VarE sroute) extraCons route = LamE [VarP sroute] $ foldr AppE (AppE route' $ VarE sroute) extraCons

21
yesod-core/test/YesodCoreTest/WaiSubsite.hs
View File

@ -1,15 +1,21 @@
{-# LANGUAGE CPP, QuasiQuotes, TemplateHaskell, TypeFamilies, MultiParamTypeClasses, OverloadedStrings #-} {-# LANGUAGE CPP, QuasiQuotes, TemplateHaskell, TypeFamilies, MultiParamTypeClasses, OverloadedStrings, ViewPatterns #-}
module YesodCoreTest.WaiSubsite (specs, Widget) where module YesodCoreTest.WaiSubsite (specs, Widget) where
import YesodCoreTest.YesodTest import YesodCoreTest.YesodTest
import Yesod.Core import Yesod.Core
import qualified Network.HTTP.Types as H import qualified Network.HTTP.Types as H
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as B (concat)
import qualified Data.ByteString.Lazy.Char8 as B8 (pack)
myApp :: Application myApp :: ByteString -> Application
myApp _ f = f $ responseLBS H.status200 [("Content-type", "text/plain")] "WAI" myApp s _ f = f $ responseLBS H.status200 [("Content-type", "text/plain")] s
getApp :: a -> WaiSubsite getApp :: a -> WaiSubsite
getApp _ = WaiSubsite myApp getApp _ = WaiSubsite $ myApp "WAI"
getAppArgs :: a -> Int -> Int -> WaiSubsite
getAppArgs _ i j = WaiSubsite $ myApp $ B.concat ["WAI - ", B8.pack $ show i, " - ", B8.pack $ show j ]
data Y = Y data Y = Y
mkYesod "Y" [parseRoutes| mkYesod "Y" [parseRoutes|
@ -17,6 +23,8 @@ mkYesod "Y" [parseRoutes|
/sub WaiSubsiteR WaiSubsite getApp /sub WaiSubsiteR WaiSubsite getApp
/nested NestedR: /nested NestedR:
/sub NestedWaiSubsiteR WaiSubsite getApp /sub NestedWaiSubsiteR WaiSubsite getApp
/nestedargs/#Int NestedArgsR:
/sub/#Int NestedArgsWaiSubsiteR WaiSubsite getAppArgs
|] |]
instance Yesod Y instance Yesod Y
@ -43,3 +51,8 @@ specs = describe "WaiSubsite" $ do
res <- request defaultRequest { pathInfo = ["nested", "sub", "foo"] } res <- request defaultRequest { pathInfo = ["nested", "sub", "foo"] }
assertStatus 200 res assertStatus 200 res
assertBodyContains "WAI" res assertBodyContains "WAI" res
it "nested subsite with arguments" $ app $ do
res <- request defaultRequest { pathInfo = ["nestedargs", "1", "sub", "2", "foo"] }
assertStatus 200 res
assertBodyContains "WAI - 1 - 2" res