diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -[Wai-Routes](https://ajnsit.github.io/wai-routes) [![Hackage](https://img.shields.io/badge/hackage-v0.9.5-brightgreen.svg)](https://hackage.haskell.org/package/wai-routes) [![Hackage-Deps](https://img.shields.io/hackage-deps/v/wai-routes.svg)](http://packdeps.haskellers.com/feed?needle=wai-routes) [![Build Status](https://img.shields.io/travis/ajnsit/wai-routes.svg)](https://travis-ci.org/ajnsit/wai-routes) [![Join the chat at https://gitter.im/ajnsit/wai-routes](https://img.shields.io/badge/gitter-join%20chat%20%E2%86%A3-blue.svg)](https://gitter.im/ajnsit/wai-routes) +[Wai-Routes](https://ajnsit.github.io/wai-routes) [![Hackage](https://img.shields.io/badge/hackage-v0.9.6-brightgreen.svg)](https://hackage.haskell.org/package/wai-routes) [![Hackage-Deps](https://img.shields.io/hackage-deps/v/wai-routes.svg)](http://packdeps.haskellers.com/feed?needle=wai-routes) [![Build Status](https://img.shields.io/travis/ajnsit/wai-routes.svg)](https://travis-ci.org/ajnsit/wai-routes) [![Join the chat at https://gitter.im/ajnsit/wai-routes](https://img.shields.io/badge/gitter-join%20chat%20%E2%86%A3-blue.svg)](https://gitter.im/ajnsit/wai-routes) ==================================== Wai-routes is a micro web framework for Haskell that focuses on typesafe URLs. @@ -109,6 +109,7 @@ Changelog ========= +* 0.9.6 : Subsites now receive parent route arguments, in line with regular nested routes * 0.9.5 : Subsites now play well with hierarchical routes * 0.9.4 : Wai-3.2 compatibility. Added functions to manipulate wai "vault". Minor changes to internal types. * 0.9.3 : Added `content` and `whenContent`. Allow http-types-0.9. diff --git a/src/Network/Wai/Middleware/Routes/Routes.hs b/src/Network/Wai/Middleware/Routes/Routes.hs --- a/src/Network/Wai/Middleware/Routes/Routes.hs +++ b/src/Network/Wai/Middleware/Routes/Routes.hs @@ -178,6 +178,7 @@ , mds404 = [| app404 |] , mds405 = [| app405 |] , mdsGetHandler = defaultGetHandler + , mdsUnwrapper = return } routes diff --git a/src/Network/Wai/Middleware/Routes/TH/Dispatch.hs b/src/Network/Wai/Middleware/Routes/TH/Dispatch.hs --- a/src/Network/Wai/Middleware/Routes/TH/Dispatch.hs +++ b/src/Network/Wai/Middleware/Routes/TH/Dispatch.hs @@ -16,7 +16,7 @@ import Network.Wai.Middleware.Routes.TH.Types import Data.Char (toLower) -data MkDispatchSettings = MkDispatchSettings +data MkDispatchSettings b site c = MkDispatchSettings { mdsRunHandler :: Q Exp , mdsSubDispatcher :: Q Exp , mdsGetPathInfo :: Q Exp @@ -25,6 +25,7 @@ , mds404 :: Q Exp , mds405 :: Q Exp , mdsGetHandler :: Maybe String -> String -> Q Exp + , mdsUnwrapper :: Exp -> Q Exp } data SDC = SDC @@ -39,7 +40,7 @@ -- view patterns. -- -- Since 1.4.0 -mkDispatchClause :: MkDispatchSettings -> [ResourceTree a] -> Q Clause +mkDispatchClause :: MkDispatchSettings b site c -> [ResourceTree a] -> Q Clause mkDispatchClause MkDispatchSettings {..} resources = do suffix <- qRunIO $ randomRIO (1000, 9999 :: Int) envName <- newName $ "env" ++ show suffix @@ -141,7 +142,7 @@ mkRunExp mmethod = do runHandlerE <- mdsRunHandler handlerE' <- mdsGetHandler mmethod name - let handlerE = foldl' AppE handlerE' allDyns + handlerE <- mdsUnwrapper $ foldl' AppE handlerE' allDyns return $ runHandlerE `AppE` handlerE `AppE` envExp @@ -175,12 +176,11 @@ subDispatcherE <- mdsSubDispatcher runHandlerE <- mdsRunHandler sub <- newName "sub" - let sub2 = LamE [VarP sub] - (foldl' (\a b -> a `AppE` b) (VarE (mkName getSub) `AppE` VarE sub) dyns) + sroute <- newName "sroute" + let allDyns = extraParams ++ dyns + let sub2 = LamE [VarP sub] (foldl' AppE (VarE (mkName getSub) `AppE` VarE sub) allDyns) let reqExp' = setPathInfoE `AppE` VarE restPath `AppE` reqExp route' = foldl' AppE (ConE (mkName name)) dyns - -- Subsites didn't work with hierarchical routes earlier - sroute = mkName "sroute" route = LamE [VarP sroute] $ foldr AppE (AppE route' $ VarE sroute) extraCons exp = subDispatcherE `AppE` runHandlerE diff --git a/src/Network/Wai/Middleware/Routes/TH/ParseRoute.hs b/src/Network/Wai/Middleware/Routes/TH/ParseRoute.hs --- a/src/Network/Wai/Middleware/Routes/TH/ParseRoute.hs +++ b/src/Network/Wai/Middleware/Routes/TH/ParseRoute.hs @@ -22,6 +22,7 @@ , mdsGetHandler = \_ _ -> [|error "mdsGetHandler"|] , mdsSetPathInfo = [|\p (_, q) -> (p, q)|] , mdsSubDispatcher = [|\_runHandler _getSub toMaster _env -> fmap toMaster . parseRoute|] + , mdsUnwrapper = return } (map removeMethods ress) helper <- newName "helper" diff --git a/test/HelloSpec.hs b/test/HelloSpec.hs --- a/test/HelloSpec.hs +++ b/test/HelloSpec.hs @@ -18,7 +18,7 @@ ---- A SMALL SUBSITE ---- -data SubRoute = SubRoute +data SubRoute = SubRoute Text class MasterContract master where getMasterName :: master -> Text @@ -29,13 +29,17 @@ getSubHomeR :: MasterContract master => HandlerS SubRoute master getSubHomeR = runHandlerM $ do + SubRoute s <- sub m <- master - plain $ T.concat ["subsite-", getMasterName m] + plain $ T.concat ["subsite-", s, "-", getMasterName m] -getSubRoute :: master -> SubRoute +getSubRoute :: master -> Text -> SubRoute getSubRoute = const SubRoute +getDefaultSubRoute :: master -> SubRoute +getDefaultSubRoute = const $ SubRoute "default" + ---- THE APPLICATION TO BE TESTED ---- data MyRoute = MyRoute @@ -47,10 +51,14 @@ / HomeR GET /some-json FooR GET /post PostR POST -/subsite SubR SubRoute getSubRoute +/subsite SubR SubRoute getDefaultSubRoute /nested NestedR: / NRootR GET /abcd AbcdR GET + /nested2 Nested2R: + /subsite SubNestedR SubRoute getDefaultSubRoute + /nested3/#Text Nested3: + /argsub SubNestedArgR SubRoute getSubRoute |] getHomeR :: Handler MyRoute @@ -113,7 +121,7 @@ describe "GET /subsite" $ it "can access the subsite correctly" $ - get "/subsite" `shouldRespondWith` "subsite-MyRoute" {matchStatus = 200, matchHeaders = ["Content-Type" <:> "text/plain; charset=utf-8"]} + get "/subsite" `shouldRespondWith` "subsite-default-MyRoute" {matchStatus = 200, matchHeaders = ["Content-Type" <:> "text/plain; charset=utf-8"]} describe "GET /nested" $ it "can access nested routes root correctly" $ @@ -122,6 +130,14 @@ describe "GET /nested/abcd" $ it "can access nested routes correctly" $ get "/nested/abcd" `shouldRespondWith` "Nested ABCD" {matchStatus = 200, matchHeaders = ["Content-Type" <:> "text/plain; charset=utf-8"]} + + describe "GET /nested/nested2/subsite" $ + it "can access the nested subsite correctly" $ + get "/nested/nested2/subsite" `shouldRespondWith` "subsite-default-MyRoute" {matchStatus = 200, matchHeaders = ["Content-Type" <:> "text/plain; charset=utf-8"]} + + describe "GET /nested/nested2/nested3/helloworld/argsub" $ + it "can pass route arguments to the nested subsite correctly" $ + get "/nested/nested2/nested3/helloworld/argsub" `shouldRespondWith` "subsite-helloworld-MyRoute" {matchStatus = 200, matchHeaders = ["Content-Type" <:> "text/plain; charset=utf-8"]} describe "GET /lambda.png" $ it "returns a file correctly" $ diff --git a/wai-routes.cabal b/wai-routes.cabal --- a/wai-routes.cabal +++ b/wai-routes.cabal @@ -1,5 +1,5 @@ name : wai-routes -version : 0.9.5 +version : 0.9.6 cabal-version : >=1.18 build-type : Simple license : MIT @@ -21,8 +21,8 @@ source-repository this type : git - location : http://github.com/ajnsit/wai-routes/tree/v0.9.5 - tag : v0.9.5 + location : http://github.com/ajnsit/wai-routes/tree/v0.9.6 + tag : v0.9.6 library build-depends : base >= 4.7 && < 4.9