diff --git a/reroute.cabal b/reroute.cabal --- a/reroute.cabal +++ b/reroute.cabal @@ -1,5 +1,5 @@ name: reroute -version: 0.2.0.1 +version: 0.2.1.0 synopsis: abstract implementation of typed and untyped web routing description: abstraction over how urls with/without parameters are mapped to their corresponding handlers homepage: http://github.com/agrafix/reroute @@ -31,6 +31,7 @@ graph-core >=0.2 && <0.3 hs-source-dirs: src default-language: Haskell2010 + ghc-options: -Wall -fno-warn-orphans test-suite reroute-test diff --git a/src/Web/Routing/AbstractRouter.hs b/src/Web/Routing/AbstractRouter.hs --- a/src/Web/Routing/AbstractRouter.hs +++ b/src/Web/Routing/AbstractRouter.hs @@ -21,6 +21,7 @@ emptyRegistry :: Registry r rootPath :: RoutePath r '[] defRoute :: RoutePath r as -> RouteAction r as -> Registry r -> Registry r + fallbackRoute :: ([T.Text] -> RouteAppliedAction r) -> Registry r -> Registry r matchRoute :: Registry r -> [T.Text] -> [(ParamMap, RouteAppliedAction r)] type ParamMap = HM.HashMap CaptureVar T.Text @@ -42,6 +43,17 @@ = RegistryState { rs_registry :: HM.HashMap reqTypes (Registry r) } + +hookAny :: (Monad m, AbstractRouter r, Eq reqTypes, Hashable reqTypes) + => reqTypes + -> ([T.Text] -> RouteAppliedAction r) + -> RegistryT r middleware reqTypes m () +hookAny reqType action = + modify $ \rs -> + rs { rs_registry = + let reg = fromMaybe emptyRegistry (HM.lookup reqType (rs_registry rs)) + in HM.insert reqType (fallbackRoute action reg) (rs_registry rs) + } hookRoute :: (Monad m, AbstractRouter r, Eq reqTypes, Hashable reqTypes) => reqTypes diff --git a/src/Web/Routing/SafeRouting.hs b/src/Web/Routing/SafeRouting.hs --- a/src/Web/Routing/SafeRouting.hs +++ b/src/Web/Routing/SafeRouting.hs @@ -30,21 +30,29 @@ data SafeRouter (m :: * -> *) a = SafeRouter instance AbstractRouter (SafeRouter m a) where - newtype Registry (SafeRouter m a) = SafeRouterReg (PathMap (m a)) + newtype Registry (SafeRouter m a) = SafeRouterReg (PathMap (m a), [[T.Text] -> m a]) newtype RoutePath (SafeRouter m a) xs = SafeRouterPath (Path xs) type RouteAction (SafeRouter m a) = HVectElim' (m a) type RouteAppliedAction (SafeRouter m a) = m a subcompCombine (SafeRouterPath p1) (SafeRouterPath p2) = SafeRouterPath $ p1 p2 - emptyRegistry = SafeRouterReg emptyPathMap + emptyRegistry = SafeRouterReg (emptyPathMap, []) rootPath = SafeRouterPath Empty - defRoute (SafeRouterPath path) action (SafeRouterReg m) = - SafeRouterReg $ - insertPathMap (RouteHandle path (flipHVectElim action)) m - matchRoute (SafeRouterReg m) pathPieces = + defRoute (SafeRouterPath path) action (SafeRouterReg (m, cAll)) = + SafeRouterReg + ( insertPathMap (RouteHandle path (flipHVectElim action)) m + , cAll + ) + fallbackRoute routeDef (SafeRouterReg (m, cAll)) = + SafeRouterReg (m, cAll ++ [routeDef]) + matchRoute (SafeRouterReg (m, cAll)) pathPieces = let matches = match m pathPieces - in zip (replicate (length matches) HM.empty) matches + matches' = + if null matches + then matches ++ (map (\f -> f pathPieces) cAll) + else matches + in zip (replicate (length matches') HM.empty) matches' data Path (as :: [*]) where diff --git a/src/Web/Routing/TextRouting.hs b/src/Web/Routing/TextRouting.hs --- a/src/Web/Routing/TextRouting.hs +++ b/src/Web/Routing/TextRouting.hs @@ -51,19 +51,26 @@ data TextRouter (m :: * -> *) a = TextRouter instance AbstractRouter (TextRouter m a) where - newtype Registry (TextRouter m a) = TextRouterRegistry (RoutingTree (m a)) + newtype Registry (TextRouter m a) = TextRouterRegistry (RoutingTree (m a), [[T.Text] -> m a]) newtype RoutePath (TextRouter m a) xs = TextRouterPath T.Text type RouteAction (TextRouter m a) = TAction m a type RouteAppliedAction (TextRouter m a) = m a subcompCombine (TextRouterPath p1) (TextRouterPath p2) = TextRouterPath $ combineRoute p1 p2 - emptyRegistry = TextRouterRegistry emptyRoutingTree + emptyRegistry = TextRouterRegistry (emptyRoutingTree, []) rootPath = TextRouterPath "/" - defRoute (TextRouterPath p) (TAction a) (TextRouterRegistry tree) = - TextRouterRegistry $ - addToRoutingTree p a tree - matchRoute (TextRouterRegistry tree) path = - matchRoute' path tree + defRoute (TextRouterPath p) (TAction a) (TextRouterRegistry (tree, cAll)) = + TextRouterRegistry + ( addToRoutingTree p a tree + , cAll + ) + fallbackRoute routeDef (TextRouterRegistry (m, cAll)) = + TextRouterRegistry (m, cAll ++ [routeDef]) + matchRoute (TextRouterRegistry (tree, cAll)) path = + let matches = matchRoute' path tree + in if null matches + then matches ++ ((zip (replicate (length cAll) HM.empty) $ map (\f -> f path) cAll)) + else matches data RegexWrapper = RegexWrapper diff --git a/test/Web/Routing/SafeRoutingSpec.hs b/test/Web/Routing/SafeRoutingSpec.hs --- a/test/Web/Routing/SafeRoutingSpec.hs +++ b/test/Web/Routing/SafeRoutingSpec.hs @@ -24,16 +24,12 @@ defR :: (Monad m, m ReturnVar ~ x) => Path ts -> HVectElim ts x -> RegistryT (SafeRouter m ReturnVar) middleware Bool m () defR path action = hookRoute True (SafeRouterPath path) (HVectElim' action) - spec :: Spec spec = describe "SafeRouting Spec" $ do it "should match known routes" $ do checkRoute "" [StrVar "root"] checkRoute "/bar" [StrVar "bar"] - it "shoudn't match unknown routes" $ - do checkRoute "/random" [] - checkRoute "/baz" [] it "should capture variables in routes" $ do checkRoute "/bar/23/baz" [IntVar 23] checkRoute "/bar/23/baz/100" [ListVar [IntVar 23, IntVar 100]] @@ -61,10 +57,13 @@ check "/plus/forty/two/forty/two" (42+42) check "/mult/forty/two/3" (42*3) check "/plus/5/89" 94 + it "should have a catch all route" $ + do checkRoute "/aslkdjk/asdaskl/aslkjd" [StrVar "aslkdjk/asdaskl/aslkjd"] + checkRoute "/zuiasf/zuiasf" [StrVar "zuiasf/zuiasf"] where pieces :: T.Text -> [T.Text] pieces = filter (not . T.null) . T.splitOn "/" - + checkRoute :: T.Text -> [ReturnVar] -> Expectation checkRoute r x = let matches = handleFun (pieces r) @@ -93,3 +92,4 @@ defR ("bar" "bingo") $ return (StrVar "bar/bingo") defR ("bar" var) $ (return . StrVar . T.pack) defR ("entry" var "audit") (return . IntVar) + hookAny True (return . StrVar . T.intercalate "/")