diff --git a/benchmarks/Benchmarks.hs b/benchmarks/Benchmarks.hs new file mode 100644 --- /dev/null +++ b/benchmarks/Benchmarks.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE OverloadedStrings, DataKinds #-} + +module Main where + +import Web.Routing.TextRouting +import Web.Routing.SafeRouting + +import Criterion.Main +import qualified Data.Text as T +import Data.List (permutations, foldl') +import System.Random (mkStdGen, randomRs) +import Data.Maybe (listToMaybe, fromMaybe) +import Data.Monoid (Monoid (..)) + + +buildRoutingTree :: [([T.Text], a)] -> RoutingTree a +buildRoutingTree = + foldl' (\t (route, val) -> addToRoutingTree (joinSegs route) val t) + emptyRoutingTree + where joinSegs = T.intercalate "/" + +lookupRoutingTreeM :: [[T.Text]] -> RoutingTree Int -> Int +lookupRoutingTreeM routes tree = + foldl' (\z route -> maybe z snd (listToMaybe $ matchRoute' route tree)) 0 routes + +buildPath :: [T.Text] -> Path '[] +buildPath = static . T.unpack . T.intercalate "/" + +buildPathMap :: [([T.Text], a)] -> PathMap a +buildPathMap = + foldl' (\t (route, val) -> insertPathMap' (buildPath route) (const val) t) mempty + +lookupPathMapM :: [[T.Text]] -> PathMap Int -> Int +lookupPathMapM rs m = + foldl' (\z route -> fromMaybe z (listToMaybe $ match m route)) 0 rs + +benchmarks :: [Benchmark] +benchmarks = + [ env setupTextMap $ \ ~(routingTree, routes') -> + bgroup "TextRouting" + [ bench "static-lookup" $ whnf (lookupRoutingTreeM routes') routingTree + ] + , env setupSafeMap $ \ ~(safeMap, routes') -> + bgroup "SafeRouting" + [ bench "static-lookup" $ whnf (lookupPathMapM routes') safeMap + ] + ] + where + strlen = 10 + seglen = 5 + num = 10 + routes = rndRoutes strlen seglen num + routesList = zip routes [1..] + setupTextMap = return (buildRoutingTree routesList, routes) + setupSafeMap = return (buildPathMap routesList, routes) + +main :: IO () +main = defaultMain benchmarks + +chunks :: Int -> [a] -> [[a]] +chunks n xs = + let (ys, xs') = splitAt n xs + in ys : chunks n xs' + +-- | Generate a number of paths consisting of a fixed number of fixed length +-- strings ("path segments") where the content of the segments are letters in +-- random order. Contains all permutations with the path. +rndRoutes :: + Int -- ^ Length of each string + -> Int -- ^ Number of segments + -> Int -- ^ Number of routes + -> [[T.Text]] +rndRoutes strlen seglen num = + take num $ concatMap permutations $ chunks seglen $ map T.pack $ + chunks strlen $ randomRs ('a', 'z') $ mkStdGen 1234 diff --git a/reroute.cabal b/reroute.cabal --- a/reroute.cabal +++ b/reroute.cabal @@ -1,5 +1,5 @@ name: reroute -version: 0.2.0.0 +version: 0.2.0.1 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 @@ -13,8 +13,11 @@ cabal-version: >=1.10 library - exposed-modules: Data.HVect, Web.Routing.AbstractRouter, Web.Routing.SafeRouting, Web.Routing.TextRouting - other-modules: Data.PolyMap + exposed-modules: Data.HVect, + Data.PolyMap, + Web.Routing.AbstractRouter, + Web.Routing.SafeRouting, + Web.Routing.TextRouting build-depends: base >=4.6 && <4.8, transformers >=0.3 && <0.5, text >= 0.11.3.1 && <1.3, @@ -23,7 +26,6 @@ hashable >=1.2 && <1.3, mtl >=2.1 && <2.3, path-pieces >=0.1 && <0.2, - hspec2 >=0.4 && <0.5, vector >=0.10 && <0.11, deepseq >= 1.1.0.2 && < 1.4, graph-core >=0.2 && <0.3 @@ -31,12 +33,13 @@ default-language: Haskell2010 -test-suite reroutetest +test-suite reroute-test type: exitcode-stdio-1.0 - hs-source-dirs: src - main-is: Web/Routing/Specs/Main.hs - other-modules: Web.Routing.Specs.SafeRoutingSpec, Web.Routing.Specs.TextRoutingSpec + hs-source-dirs: test + main-is: Spec.hs + other-modules: Web.Routing.SafeRoutingSpec, Web.Routing.TextRoutingSpec build-depends: base >=4.6 && <4.8, + reroute, transformers >=0.3 && <0.5, text >= 0.11.3.1 && <1.3, unordered-containers ==0.2.*, @@ -50,6 +53,26 @@ graph-core >=0.2 && <0.3 default-language: Haskell2010 ghc-options: -Wall -fno-warn-orphans + +benchmark reroute-benchmarks + type: exitcode-stdio-1.0 + ghc-options: -Wall -O2 + hs-source-dirs: src benchmarks + default-language: Haskell2010 + main-is: Benchmarks.hs + build-depends: + base, + criterion, + text, + mtl, + unordered-containers, + vector, + hashable, + regex-compat, + random, + deepseq, + path-pieces, + graph-core source-repository head type: git diff --git a/src/Web/Routing/Specs/Main.hs b/src/Web/Routing/Specs/Main.hs deleted file mode 100644 --- a/src/Web/Routing/Specs/Main.hs +++ /dev/null @@ -1,10 +0,0 @@ -import qualified Web.Routing.Specs.TextRoutingSpec -import qualified Web.Routing.Specs.SafeRoutingSpec - -import Test.Hspec - -main :: IO () -main = - hspec $ - do Web.Routing.Specs.TextRoutingSpec.spec - Web.Routing.Specs.SafeRoutingSpec.spec diff --git a/src/Web/Routing/Specs/SafeRoutingSpec.hs b/src/Web/Routing/Specs/SafeRoutingSpec.hs deleted file mode 100644 --- a/src/Web/Routing/Specs/SafeRoutingSpec.hs +++ /dev/null @@ -1,98 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE OverloadedStrings #-} -#if MIN_VERSION_base(4,7,0) -{-# LANGUAGE AllowAmbiguousTypes #-} -#endif -module Web.Routing.Specs.SafeRoutingSpec where - -import Test.Hspec -import Data.HVect - -import Control.Monad.Identity -import Web.Routing.SafeRouting -import Web.Routing.AbstractRouter -import Data.Monoid (mconcat) -import Control.Applicative (Applicative (..)) -import qualified Data.Text as T - -data ReturnVar - = IntVar Int - | StrVar T.Text - | BoolVar Bool - | ListVar [ReturnVar] - deriving (Show, Eq, Read) - -defR :: (Monad m, HVectElim ts (m ReturnVar) ~ HVectElim ts 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]] - checkRoute "/bar/23/100" [ListVar [IntVar 23, IntVar 100]] - checkRoute "/entry/344/2014-20-14T12:23" [ListVar [IntVar 344, StrVar "2014-20-14T12:23"]] - checkRoute "/entry/bytags/344/2014-20-14T12:23" [ListVar [IntVar 344, StrVar "2014-20-14T12:23"]] - checkRoute "/entry/2/rel/3" [ListVar [IntVar 2, IntVar 3]] - it "should handle multiple possible matches correctly" $ - do checkRoute "/bar/5" [IntVar 5, StrVar "5"] - checkRoute "/bar/bingo" [StrVar "bar/bingo", StrVar "bingo"] - checkRoute "/entry/1/audit" [IntVar 1,ListVar [IntVar 1,StrVar "audit"]] - it "should provide an Applicative interface" $ - do let numbers = - mconcat - [ singleton var id - , singleton ("forty" "two") (42 :: Int) - ] - operators = - mconcat - [ singleton "plus" ((+) :: Int -> Int -> Int) - , singleton "mult" (*) - ] - routes = operators <*> numbers <*> numbers - check path val = match routes (pieces path) `shouldBe` [val] - check "/plus/forty/two/forty/two" (42+42) - check "/mult/forty/two/3" (42*3) - check "/plus/5/89" 94 - 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) - in (map (runIdentity . snd) matches) `shouldBe` x - - handleFun :: [T.Text] -> [(ParamMap, Identity ReturnVar)] - handleFun = handleFun' True - (_, handleFun', _) = - runIdentity (runRegistry SafeRouter handleDefs) - - handleDefs = - do defR root $ return (StrVar "root") - defR "bar" $ return (StrVar "bar") - defR ("bar" var) (return . IntVar) - defR ("bar" var "baz") (return . IntVar) - defR ("bar" var "baz" var) $ \i i2 -> - return (ListVar [IntVar i, IntVar i2]) - defR ("bar" var var) $ \i i2 -> - return (ListVar [IntVar i, IntVar i2]) - defR ("entry" var var) $ \i st -> - return (ListVar [IntVar i, StrVar st]) - defR ("entry/bytags" var var) $ \i st -> - return (ListVar [IntVar i, StrVar st]) - defR ("entry" var "rel" var) $ \i i2 -> - return (ListVar [IntVar i, IntVar i2]) - defR ("bar" "bingo") $ return (StrVar "bar/bingo") - defR ("bar" var) $ (return . StrVar . T.pack) - defR ("entry" var "audit") (return . IntVar) diff --git a/src/Web/Routing/Specs/TextRoutingSpec.hs b/src/Web/Routing/Specs/TextRoutingSpec.hs deleted file mode 100644 --- a/src/Web/Routing/Specs/TextRoutingSpec.hs +++ /dev/null @@ -1,81 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Web.Routing.Specs.TextRoutingSpec (spec) where - -import Test.Hspec - -import Web.Routing.TextRouting -import qualified Web.Routing.AbstractRouter as R -import qualified Data.HashMap.Strict as HM - -spec :: Spec -spec = - do matchNodeDesc - matchRouteDesc - parseRouteNodeDesc - -matchNodeDesc :: Spec -matchNodeDesc = - describe "matchNode" $ - do it "shouldn't match to root node" $ - matchNode "foo" RouteNodeRoot `shouldBe` (False, Nothing) - it "should capture basic variables" $ - matchNode "123" (RouteNodeCapture (R.CaptureVar "x")) `shouldBe` (True, Just (R.CaptureVar "x", "123")) - it "should work with regex" $ - matchNode "123" (RouteNodeRegex (R.CaptureVar "x") (buildRegex "^[0-9]+$")) `shouldBe` (True, Just (R.CaptureVar "x", "123")) - -matchRouteDesc :: Spec -matchRouteDesc = - describe "matchRoute" $ - do it "shouldn't match unknown routes" $ - do matchRoute "random" routingTree `shouldBe` noMatches - matchRoute "/baz" routingTree `shouldBe` noMatches - it "should match known routes" $ - do matchRoute "/" routingTree `shouldBe` oneMatch emptyParamMap [1] - matchRoute "/bar" routingTree `shouldBe` oneMatch emptyParamMap [2] - it "should capture variables in routes" $ - do matchRoute "/bar/5" routingTree `shouldBe` oneMatch (vMap [("baz", "5")]) [3] - matchRoute "/bar/23/baz" routingTree `shouldBe` oneMatch (vMap [("baz", "23")]) [4] - matchRoute "/bar/23/baz/100" routingTree `shouldBe` oneMatch (vMap [("baz", "23"), ("bim", "100")]) [4] - matchRoute "/ba/23/100" routingTree `shouldBe` oneMatch (vMap [("baz", "23"), ("bim", "100")]) [4] - matchRoute "/entry/344/2014-20-14T12:23" routingTree `shouldBe` oneMatch (vMap [("cid", "344"), ("since", "2014-20-14T12:23")]) [6] - matchRoute "/entry/bytags/344/2014-20-14T12:23" routingTree `shouldBe` oneMatch (vMap [("cid", "344"), ("since", "2014-20-14T12:23")]) [7] - matchRoute "/entry/2/rel/3" routingTree `shouldBe` oneMatch (vMap [("eid", "2"), ("cid", "3")]) [9] - it "should handle multiple possibile matches correctly" $ - do matchRoute "/bar/bingo" routingTree `shouldBe` multiMatch - matchRoute "/entry/1/audit" routingTree `shouldBe` multiMatch' - where - vMap kv = - HM.fromList $ map (\(k, v) -> (R.CaptureVar k, v)) kv - multiMatch = - ((oneMatch emptyParamMap [5]) - ++ oneMatch (vMap [("baz", "bingo")]) [3]) - multiMatch' = - ((oneMatch (vMap [("eid", "1")]) [8]) - ++ (oneMatch (vMap [("since", "audit"), ("cid", "1")]) [6])) - noMatches = [] - oneMatch pm m = [(pm, m)] - routingTree = - foldl (\tree (route, action) -> addToRoutingTree route action tree) emptyRoutingTree routes - routes = - [ ("/", [1]) - , ("/bar", [2 :: Int]) - , ("/bar/:baz", [3]) - , ("/bar/bingo", [5]) - , ("/bar/:baz/baz", [4]) - , ("/bar/:baz/baz/:bim", [4]) - , ("/ba/:baz/:bim", [4]) - , ("/entry/:cid/:since", [6]) - , ("/entry/bytags/:cid/:since", [7]) - , ("/entry/:eid/audit", [8]) - , ("/entry/:eid/rel/:cid", [9]) - ] - -parseRouteNodeDesc :: Spec -parseRouteNodeDesc = - describe "parseRouteNode" $ - do it "parses text nodes correctly" $ - parseRouteNode "foo" `shouldBe` RouteNodeText "foo" - it "parses capture variables" $ - parseRouteNode ":bar" `shouldBe` RouteNodeCapture (R.CaptureVar "bar") - it "parses regex capture variables" $ - parseRouteNode "{bar:^[0-9]$}" `shouldBe` RouteNodeRegex (R.CaptureVar "bar") (buildRegex "^[0-9]$") diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/Web/Routing/SafeRoutingSpec.hs b/test/Web/Routing/SafeRoutingSpec.hs new file mode 100644 --- /dev/null +++ b/test/Web/Routing/SafeRoutingSpec.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} +module Web.Routing.SafeRoutingSpec where + +import Test.Hspec +import Data.HVect + +import Control.Monad.Identity +import Web.Routing.SafeRouting +import Web.Routing.AbstractRouter +import Data.Monoid (mconcat) +import Control.Applicative (Applicative (..)) +import qualified Data.Text as T + +data ReturnVar + = IntVar Int + | StrVar T.Text + | BoolVar Bool + | ListVar [ReturnVar] + deriving (Show, Eq, Read) + +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]] + checkRoute "/bar/23/100" [ListVar [IntVar 23, IntVar 100]] + checkRoute "/entry/344/2014-20-14T12:23" [ListVar [IntVar 344, StrVar "2014-20-14T12:23"]] + checkRoute "/entry/bytags/344/2014-20-14T12:23" [ListVar [IntVar 344, StrVar "2014-20-14T12:23"]] + checkRoute "/entry/2/rel/3" [ListVar [IntVar 2, IntVar 3]] + it "should handle multiple possible matches correctly" $ + do checkRoute "/bar/5" [IntVar 5, StrVar "5"] + checkRoute "/bar/bingo" [StrVar "bar/bingo", StrVar "bingo"] + checkRoute "/entry/1/audit" [IntVar 1,ListVar [IntVar 1,StrVar "audit"]] + it "should provide an Applicative interface" $ + do let numbers = + mconcat + [ singleton var id + , singleton ("forty" "two") (42 :: Int) + ] + operators = + mconcat + [ singleton "plus" ((+) :: Int -> Int -> Int) + , singleton "mult" (*) + ] + routes = operators <*> numbers <*> numbers + check path val = match routes (pieces path) `shouldBe` [val] + check "/plus/forty/two/forty/two" (42+42) + check "/mult/forty/two/3" (42*3) + check "/plus/5/89" 94 + 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) + in (map (runIdentity . snd) matches) `shouldBe` x + + handleFun :: [T.Text] -> [(ParamMap, Identity ReturnVar)] + handleFun = handleFun' True + (_, handleFun', _) = + runIdentity (runRegistry SafeRouter handleDefs) + + handleDefs = + do defR root $ return (StrVar "root") + defR "bar" $ return (StrVar "bar") + defR ("bar" var) (return . IntVar) + defR ("bar" var "baz") (return . IntVar) + defR ("bar" var "baz" var) $ \i i2 -> + return (ListVar [IntVar i, IntVar i2]) + defR ("bar" var var) $ \i i2 -> + return (ListVar [IntVar i, IntVar i2]) + defR ("entry" var var) $ \i st -> + return (ListVar [IntVar i, StrVar st]) + defR ("entry/bytags" var var) $ \i st -> + return (ListVar [IntVar i, StrVar st]) + defR ("entry" var "rel" var) $ \i i2 -> + return (ListVar [IntVar i, IntVar i2]) + defR ("bar" "bingo") $ return (StrVar "bar/bingo") + defR ("bar" var) $ (return . StrVar . T.pack) + defR ("entry" var "audit") (return . IntVar) diff --git a/test/Web/Routing/TextRoutingSpec.hs b/test/Web/Routing/TextRoutingSpec.hs new file mode 100644 --- /dev/null +++ b/test/Web/Routing/TextRoutingSpec.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE OverloadedStrings #-} +module Web.Routing.TextRoutingSpec (spec) where + +import Test.Hspec + +import Web.Routing.TextRouting +import qualified Web.Routing.AbstractRouter as R +import qualified Data.HashMap.Strict as HM + +spec :: Spec +spec = + do matchNodeDesc + matchRouteDesc + parseRouteNodeDesc + +matchNodeDesc :: Spec +matchNodeDesc = + describe "matchNode" $ + do it "shouldn't match to root node" $ + matchNode "foo" RouteNodeRoot `shouldBe` (False, Nothing) + it "should capture basic variables" $ + matchNode "123" (RouteNodeCapture (R.CaptureVar "x")) `shouldBe` (True, Just (R.CaptureVar "x", "123")) + it "should work with regex" $ + matchNode "123" (RouteNodeRegex (R.CaptureVar "x") (buildRegex "^[0-9]+$")) `shouldBe` (True, Just (R.CaptureVar "x", "123")) + +matchRouteDesc :: Spec +matchRouteDesc = + describe "matchRoute" $ + do it "shouldn't match unknown routes" $ + do matchRoute "random" routingTree `shouldBe` noMatches + matchRoute "/baz" routingTree `shouldBe` noMatches + it "should match known routes" $ + do matchRoute "/" routingTree `shouldBe` oneMatch emptyParamMap [1] + matchRoute "/bar" routingTree `shouldBe` oneMatch emptyParamMap [2] + it "should capture variables in routes" $ + do matchRoute "/bar/5" routingTree `shouldBe` oneMatch (vMap [("baz", "5")]) [3] + matchRoute "/bar/23/baz" routingTree `shouldBe` oneMatch (vMap [("baz", "23")]) [4] + matchRoute "/bar/23/baz/100" routingTree `shouldBe` oneMatch (vMap [("baz", "23"), ("bim", "100")]) [4] + matchRoute "/ba/23/100" routingTree `shouldBe` oneMatch (vMap [("baz", "23"), ("bim", "100")]) [4] + matchRoute "/entry/344/2014-20-14T12:23" routingTree `shouldBe` oneMatch (vMap [("cid", "344"), ("since", "2014-20-14T12:23")]) [6] + matchRoute "/entry/bytags/344/2014-20-14T12:23" routingTree `shouldBe` oneMatch (vMap [("cid", "344"), ("since", "2014-20-14T12:23")]) [7] + matchRoute "/entry/2/rel/3" routingTree `shouldBe` oneMatch (vMap [("eid", "2"), ("cid", "3")]) [9] + it "should handle multiple possibile matches correctly" $ + do matchRoute "/bar/bingo" routingTree `shouldBe` multiMatch + matchRoute "/entry/1/audit" routingTree `shouldBe` multiMatch' + where + vMap kv = + HM.fromList $ map (\(k, v) -> (R.CaptureVar k, v)) kv + multiMatch = + ((oneMatch emptyParamMap [5]) + ++ oneMatch (vMap [("baz", "bingo")]) [3]) + multiMatch' = + ((oneMatch (vMap [("eid", "1")]) [8]) + ++ (oneMatch (vMap [("since", "audit"), ("cid", "1")]) [6])) + noMatches = [] + oneMatch pm m = [(pm, m)] + routingTree = + foldl (\tree (route, action) -> addToRoutingTree route action tree) emptyRoutingTree routes + routes = + [ ("/", [1]) + , ("/bar", [2 :: Int]) + , ("/bar/:baz", [3]) + , ("/bar/bingo", [5]) + , ("/bar/:baz/baz", [4]) + , ("/bar/:baz/baz/:bim", [4]) + , ("/ba/:baz/:bim", [4]) + , ("/entry/:cid/:since", [6]) + , ("/entry/bytags/:cid/:since", [7]) + , ("/entry/:eid/audit", [8]) + , ("/entry/:eid/rel/:cid", [9]) + ] + +parseRouteNodeDesc :: Spec +parseRouteNodeDesc = + describe "parseRouteNode" $ + do it "parses text nodes correctly" $ + parseRouteNode "foo" `shouldBe` RouteNodeText "foo" + it "parses capture variables" $ + parseRouteNode ":bar" `shouldBe` RouteNodeCapture (R.CaptureVar "bar") + it "parses regex capture variables" $ + parseRouteNode "{bar:^[0-9]$}" `shouldBe` RouteNodeRegex (R.CaptureVar "bar") (buildRegex "^[0-9]$")