commit ghc-reroute for openSUSE:Factory

Hello community, here is the log from the commit of package ghc-reroute for openSUSE:Factory checked in at 2016-11-02 12:45:02 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-reroute (Old) and /work/SRC/openSUSE:Factory/.ghc-reroute.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-reroute" Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-reroute/ghc-reroute.changes 2016-07-27 16:10:22.000000000 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-reroute.new/ghc-reroute.changes 2016-11-02 12:45:08.000000000 +0100 @@ -1,0 +2,5 @@ +Thu Sep 15 06:47:08 UTC 2016 - psimons@suse.com + +- Update to version 0.4.0.1 revision 0 with cabal2obs. + +------------------------------------------------------------------- Old: ---- reroute-0.3.1.0.tar.gz New: ---- reroute-0.4.0.1.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-reroute.spec ++++++ --- /var/tmp/diff_new_pack.qOPeHu/_old 2016-11-02 12:45:10.000000000 +0100 +++ /var/tmp/diff_new_pack.qOPeHu/_new 2016-11-02 12:45:10.000000000 +0100 @@ -19,32 +19,27 @@ %global pkg_name reroute %bcond_with tests Name: ghc-%{pkg_name} -Version: 0.3.1.0 +Version: 0.4.0.1 Release: 0 Summary: Abstract implementation of typed and untyped web routing License: MIT -Group: System/Libraries +Group: Development/Languages/Other Url: https://hackage.haskell.org/package/%{pkg_name} Source0: https://hackage.haskell.org/package/%{pkg_name}-%{version}/%{pkg_name}-%{version}.tar.gz BuildRequires: ghc-Cabal-devel -# Begin cabal-rpm deps: BuildRequires: ghc-deepseq-devel -BuildRequires: ghc-graph-core-devel BuildRequires: ghc-hashable-devel BuildRequires: ghc-hvect-devel BuildRequires: ghc-mtl-devel BuildRequires: ghc-path-pieces-devel -BuildRequires: ghc-regex-compat-devel BuildRequires: ghc-rpm-macros BuildRequires: ghc-text-devel -BuildRequires: ghc-transformers-devel BuildRequires: ghc-unordered-containers-devel -BuildRequires: ghc-vector-devel BuildRoot: %{_tmppath}/%{name}-%{version}-build %if %{with tests} BuildRequires: ghc-hspec-devel +BuildRequires: ghc-vector-devel %endif -# End cabal-rpm deps %description Abstraction over how urls with/without parameters are mapped to their @@ -64,20 +59,14 @@ %prep %setup -q -n %{pkg_name}-%{version} - %build %ghc_lib_build - %install %ghc_lib_install - %check -%if %{with tests} -%{cabal} test -%endif - +%cabal_test %post devel %ghc_pkg_recache ++++++ reroute-0.3.1.0.tar.gz -> reroute-0.4.0.1.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/reroute-0.3.1.0/README.md new/reroute-0.4.0.1/README.md --- old/reroute-0.3.1.0/README.md 2015-08-13 17:30:43.000000000 +0200 +++ new/reroute-0.4.0.1/README.md 2016-08-25 17:15:08.000000000 +0200 @@ -1,7 +1,7 @@ reroute ===== -[](https://travis-ci.org/agrafix/reroute) +[](https://travis-ci.org/agrafix/Spock) [](http://packdeps.haskellers.com/reverse/reroute) @@ -18,4 +18,4 @@ # Install * Using cabal: `cabal install reroute` -* From Source: `git clone https://github.com/agrafix/reroute.git && cd reroute && cabal install` \ No newline at end of file +* From Source: `git clone https://github.com/agrafix/Spock.git && cd Spock/reroute && cabal install` diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/reroute-0.3.1.0/benchmarks/Benchmarks.hs new/reroute-0.4.0.1/benchmarks/Benchmarks.hs --- old/reroute-0.3.1.0/benchmarks/Benchmarks.hs 2015-08-13 17:30:43.000000000 +0200 +++ new/reroute-0.4.0.1/benchmarks/Benchmarks.hs 2016-08-26 12:33:19.000000000 +0200 @@ -2,7 +2,7 @@ module Main where -import Web.Routing.TextRouting +import Web.Routing.Combinators import Web.Routing.SafeRouting import Criterion.Main @@ -10,25 +10,13 @@ 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 "/" +buildPath :: [T.Text] -> PathInternal '[] +buildPath = toInternalPath . static . T.unpack . T.intercalate "/" buildPathMap :: [([T.Text], a)] -> PathMap a buildPathMap = - foldl' (\t (route, val) -> insertPathMap' (buildPath route) (const val) t) mempty + foldl' (\t (route, val) -> insertPathMap' (buildPath route) (const val) t) emptyPathMap lookupPathMapM :: [[T.Text]] -> PathMap Int -> Int lookupPathMapM rs m = @@ -36,11 +24,7 @@ benchmarks :: [Benchmark] benchmarks = - [ env setupTextMap $ \ ~(routingTree, routes') -> - bgroup "TextRouting" - [ bench "static-lookup" $ whnf (lookupRoutingTreeM routes') routingTree - ] - , env setupSafeMap $ \ ~(safeMap, routes') -> + [ env setupSafeMap $ \ ~(safeMap, routes') -> bgroup "SafeRouting" [ bench "static-lookup" $ whnf (lookupPathMapM routes') safeMap ] @@ -51,7 +35,6 @@ num = 10 routes = rndRoutes strlen seglen num routesList = zip routes [1..] - setupTextMap = return (buildRoutingTree routesList, routes) setupSafeMap = return (buildPathMap routesList, routes) main :: IO () diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/reroute-0.3.1.0/reroute.cabal new/reroute-0.4.0.1/reroute.cabal --- old/reroute-0.3.1.0/reroute.cabal 2015-08-13 17:30:43.000000000 +0200 +++ new/reroute-0.4.0.1/reroute.cabal 2016-08-26 12:04:36.000000000 +0200 @@ -1,13 +1,13 @@ name: reroute -version: 0.3.1.0 +version: 0.4.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 +homepage: http://github.com/agrafix/Spock license: MIT license-file: LICENSE author: Alexander Thiemann , Tim Baumann maintainer: Alexander Thiemann -copyright: (c) 2014 - 2015 Alexander Thiemann , Tim Baumann +copyright: (c) 2014 - 2016 Alexander Thiemann , Tim Baumann category: Web build-type: Simple cabal-version: >=1.10 @@ -17,22 +17,18 @@ library exposed-modules: - Data.PolyMap, - Web.Routing.AbstractRouter, - Web.Routing.SafeRouting, - Web.Routing.TextRouting + Data.PolyMap, + Web.Routing.Router, + Web.Routing.SafeRouting, + Web.Routing.Combinators build-depends: base >=4.6 && <5, deepseq >= 1.1.0.2, - graph-core >=0.2.1, hashable >=1.2, mtl >=2.1, path-pieces >=0.1, - regex-compat >=0.95, text >= 0.11.3.1, - transformers >=0.3, unordered-containers >=0.2, - vector >=0.10, hvect >=0.2 hs-source-dirs: src default-language: Haskell2010 @@ -44,24 +40,23 @@ hs-source-dirs: test main-is: Spec.hs other-modules: - Web.Routing.SafeRoutingSpec, - Web.Routing.TextRoutingSpec + Web.Routing.SafeRoutingSpec build-depends: - base, - hspec, - mtl, - reroute, - text, - unordered-containers, - vector, - hvect + base, + hspec, + mtl, + reroute, + text, + unordered-containers, + vector, + hvect 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 + hs-source-dirs: benchmarks default-language: Haskell2010 main-is: Benchmarks.hs build-depends: @@ -77,8 +72,9 @@ deepseq, path-pieces, graph-core, - hvect + hvect, + reroute source-repository head type: git - location: git://github.com/agrafix/reroute.git + location: git://github.com/agrafix/Spock.git diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/reroute-0.3.1.0/src/Data/PolyMap.hs new/reroute-0.4.0.1/src/Data/PolyMap.hs --- old/reroute-0.3.1.0/src/Data/PolyMap.hs 2015-08-13 17:30:43.000000000 +0200 +++ new/reroute-0.4.0.1/src/Data/PolyMap.hs 2016-08-25 13:02:10.000000000 +0200 @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -14,8 +15,12 @@ import Prelude hiding (lookup, zipWith, zip) import Data.Typeable +#if MIN_VERSION_base(4,8,0) +import Control.Applicative (Alternative ((<|>)), liftA2) +#else import Control.Applicative (Applicative (..), Alternative ((<|>)), liftA2) import Data.Monoid (Monoid (..)) +#endif import GHC.Exts (Constraint) data PolyMap (c :: * -> Constraint) (f :: * -> *) (a :: *) where @@ -153,7 +158,7 @@ -> PolyMap c f a union = unionWith (<|>) -zipWith' :: +zipWith' :: (forall p. c p => Maybe (f (p -> a)) -> Maybe (f (p -> b)) -> Maybe (f (p -> d))) -> PolyMap c f a -> PolyMap c f b diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/reroute-0.3.1.0/src/Web/Routing/AbstractRouter.hs new/reroute-0.4.0.1/src/Web/Routing/AbstractRouter.hs --- old/reroute-0.3.1.0/src/Web/Routing/AbstractRouter.hs 2015-08-13 17:30:43.000000000 +0200 +++ new/reroute-0.4.0.1/src/Web/Routing/AbstractRouter.hs 1970-01-01 01:00:00.000000000 +0100 @@ -1,123 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE RankNTypes #-} -module Web.Routing.AbstractRouter where - -import Control.Applicative -import Control.Monad.RWS.Strict -import Data.Hashable -import Data.Maybe -import qualified Data.HashMap.Strict as HM -import qualified Data.Text as T -import Control.DeepSeq (NFData (..)) - -class AbstractRouter r where - data Registry r :: * - data RoutePath r :: [*] -> * - type RouteAction r :: [*] -> * - type RouteAppliedAction r - subcompCombine :: RoutePath r '[] -> RoutePath r as -> RoutePath r as - 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 - -newtype CaptureVar - = CaptureVar { unCaptureVar :: T.Text } - deriving (Show, Eq, Hashable, NFData) - -newtype RegistryT r middleware reqTypes (m :: * -> *) a - = RegistryT { runRegistryT :: RWST (RoutePath r '[]) [middleware] (RegistryState r reqTypes) m a } - deriving (Monad, Functor, Applicative, MonadIO - , MonadReader (RoutePath r '[]) - , MonadWriter [middleware] - , MonadState (RegistryState r reqTypes) - , MonadTrans - ) - -data RegistryState r reqTypes - = 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 - -> RoutePath r as - -> RouteAction r as - -> RegistryT r middleware reqTypes m () -hookRoute reqType path action = - do basePath <- ask - modify $ \rs -> - rs { rs_registry = - let reg = fromMaybe emptyRegistry (HM.lookup reqType (rs_registry rs)) - reg' = defRoute (basePath `subcompCombine` path) action reg - in HM.insert reqType reg' (rs_registry rs) - } - -middleware :: Monad m - => middleware - -> RegistryT r middleware reqTypes m () -middleware x = tell [x] - -subcomponent :: (Monad m, AbstractRouter r) - => RoutePath r '[] - -> RegistryT r middleware reqTypes m a - -> RegistryT r middleware reqTypes m a -subcomponent basePath (RegistryT subReg) = - do parentSt <- get - parentBasePath <- ask - let childBasePath = parentBasePath `subcompCombine` basePath - childSt = parentSt - (a, parentSt', middleware') <- - lift $ runRWST subReg childBasePath childSt - put parentSt' - tell middleware' - return a - -swapMonad :: - (Monad n, Monad m, AbstractRouter r) - => (forall b. n b -> m b) - -> RegistryT r middleware reqTypes n a - -> RegistryT r middleware reqTypes m a -swapMonad liftLower (RegistryT subReg) = - do parentSt <- get - basePath <- ask - (a, parentSt', middleware') <- - lift $ liftLower $ runRWST subReg basePath parentSt - put parentSt' - tell middleware' - return a - -runRegistry :: (Monad m, AbstractRouter r, Hashable reqTypes, Eq reqTypes) - => r - -> RegistryT r middleware reqTypes m a - -> m (a, reqTypes -> [T.Text] -> [(ParamMap, RouteAppliedAction r)], [middleware]) -runRegistry _ (RegistryT rwst) = - do (val, st, w) <- runRWST rwst rootPath initSt - return (val, handleF (rs_registry st), w) - where - handleF hm ty route = - case HM.lookup ty hm of - Nothing -> [] - Just registry -> - matchRoute registry (filter (not . T.null) route) - initSt = - RegistryState - { rs_registry = HM.empty - } diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/reroute-0.3.1.0/src/Web/Routing/Combinators.hs new/reroute-0.4.0.1/src/Web/Routing/Combinators.hs --- old/reroute-0.3.1.0/src/Web/Routing/Combinators.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/reroute-0.4.0.1/src/Web/Routing/Combinators.hs 2016-08-25 13:02:10.000000000 +0200 @@ -0,0 +1,78 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +module Web.Routing.Combinators where + +import Data.HVect +import Data.String +import Data.Typeable (Typeable) +import Web.PathPieces +import qualified Data.Text as T + +import Web.Routing.SafeRouting + +data PathState = Open | Closed + +data Path (as :: [*]) (pathState :: PathState) where + Empty :: Path '[] 'Open + StaticCons :: T.Text -> Path as ps -> Path as ps + VarCons :: (PathPiece a, Typeable a) => Path as ps -> Path (a ': as) ps + Wildcard :: Path as 'Open -> Path (T.Text ': as) 'Closed + +toInternalPath :: Path as pathState -> PathInternal as +toInternalPath Empty = PI_Empty +toInternalPath (StaticCons t p) = PI_StaticCons t (toInternalPath p) +toInternalPath (VarCons p) = PI_VarCons (toInternalPath p) +toInternalPath (Wildcard p) = PI_Wildcard (toInternalPath p) + +type Var a = Path (a ': '[]) 'Open + +-- | A route parameter +var :: (Typeable a, PathPiece a) => Path (a ': '[]) 'Open +var = VarCons Empty + +-- | A static route piece +static :: String -> Path '[] 'Open +static s = + let pieces = filter (not . T.null) $ T.splitOn "/" $ T.pack s + in foldr StaticCons Empty pieces + +instance (a ~ '[], pathState ~ 'Open) => IsString (Path a pathState) where + fromString = static + +-- | The root of a path piece. Use to define a handler for "/" +root :: Path '[] 'Open +root = Empty + +-- | Matches the rest of the route. Should be the last part of the path. +wildcard :: Path '[T.Text] 'Closed +wildcard = Wildcard Empty + +() :: Path as 'Open -> Path bs ps2 -> Path (Append as bs) ps2 +() Empty xs = xs +() (StaticCons pathPiece xs) ys = StaticCons pathPiece (xs ys) +() (VarCons xs) ys = VarCons (xs ys) + +pathToRep :: Path as ps -> Rep as +pathToRep Empty = RNil +pathToRep (StaticCons _ p) = pathToRep p +pathToRep (VarCons p) = RCons (pathToRep p) +pathToRep (Wildcard p) = RCons (pathToRep p) + +renderRoute :: Path as 'Open -> HVect as -> T.Text +renderRoute p = combineRoutePieces . renderRoute' p + +renderRoute' :: Path as 'Open -> HVect as -> [T.Text] +renderRoute' Empty _ = [] +renderRoute' (StaticCons pathPiece pathXs) paramXs = + ( pathPiece : renderRoute' pathXs paramXs ) +renderRoute' (VarCons pathXs) (val :&: paramXs) = + ( toPathPiece val : renderRoute' pathXs paramXs) +#if __GLASGOW_HASKELL__ < 800 +renderRoute' _ _ = + error "This will never happen." +#endif diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/reroute-0.3.1.0/src/Web/Routing/Router.hs new/reroute-0.4.0.1/src/Web/Routing/Router.hs --- old/reroute-0.3.1.0/src/Web/Routing/Router.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/reroute-0.4.0.1/src/Web/Routing/Router.hs 2016-08-25 13:02:10.000000000 +0200 @@ -0,0 +1,112 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RankNTypes #-} +module Web.Routing.Router where + +import Web.Routing.SafeRouting + +#if MIN_VERSION_base(4,8,0) +#else +import Control.Applicative +#endif +import Control.Monad.RWS.Strict +import Data.Hashable +import Data.Maybe +import qualified Data.HashMap.Strict as HM +import qualified Data.Text as T + +newtype RegistryT n b middleware reqTypes (m :: * -> *) a + = RegistryT + { runRegistryT :: RWST (PathInternal '[]) [middleware] (RegistryState n b reqTypes) m a + } + deriving (Monad, Functor, Applicative, MonadIO + , MonadReader (PathInternal '[]) + , MonadWriter [middleware] + , MonadState (RegistryState n b reqTypes) + , MonadTrans + ) + +data RegistryState n b reqTypes + = RegistryState + { rs_registry :: HM.HashMap reqTypes (Registry n b) + } + +hookAny :: (Monad m, Eq reqTypes, Hashable reqTypes) + => reqTypes + -> ([T.Text] -> n b) + -> RegistryT n b 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, Eq reqTypes, Hashable reqTypes) + => reqTypes + -> PathInternal as + -> HVectElim' (n b) as + -> RegistryT n b middleware reqTypes m () +hookRoute reqType path action = + do basePath <- ask + modify $ \rs -> + rs { rs_registry = + let reg = fromMaybe emptyRegistry (HM.lookup reqType (rs_registry rs)) + reg' = defRoute (basePath path) action reg + in HM.insert reqType reg' (rs_registry rs) + } + +middleware :: Monad m + => middleware + -> RegistryT n b middleware reqTypes m () +middleware x = tell [x] + +subcomponent :: (Monad m) + => PathInternal '[] + -> RegistryT n b middleware reqTypes m a + -> RegistryT n b middleware reqTypes m a +subcomponent basePath (RegistryT subReg) = + do parentSt <- get + parentBasePath <- ask + let childBasePath = parentBasePath basePath + childSt = parentSt + (a, parentSt', middleware') <- + lift $ runRWST subReg childBasePath childSt + put parentSt' + tell middleware' + return a + +swapMonad :: + Monad m + => (forall b. n b -> m b) + -> RegistryT x y middleware reqTypes n a + -> RegistryT x y middleware reqTypes m a +swapMonad liftLower (RegistryT subReg) = + do parentSt <- get + basePath <- ask + (a, parentSt', middleware') <- + lift $ liftLower $ runRWST subReg basePath parentSt + put parentSt' + tell middleware' + return a + +runRegistry :: (Monad m, Hashable reqTypes, Eq reqTypes) + => RegistryT n b middleware reqTypes m a + -> m (a, reqTypes -> [T.Text] -> [n b], [middleware]) +runRegistry (RegistryT rwst) = + do (val, st, w) <- runRWST rwst PI_Empty initSt + return (val, handleF (rs_registry st), w) + where + handleF hm ty route = + case HM.lookup ty hm of + Nothing -> [] + Just registry -> + matchRoute registry (filter (not . T.null) route) + initSt = + RegistryState + { rs_registry = HM.empty + } diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/reroute-0.3.1.0/src/Web/Routing/SafeRouting.hs new/reroute-0.4.0.1/src/Web/Routing/SafeRouting.hs --- old/reroute-0.3.1.0/src/Web/Routing/SafeRouting.hs 2015-08-13 17:30:43.000000000 +0200 +++ new/reroute-0.4.0.1/src/Web/Routing/SafeRouting.hs 2016-08-25 13:02:10.000000000 +0200 @@ -1,7 +1,9 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} @@ -10,13 +12,14 @@ import qualified Data.PolyMap as PM import Data.HVect hiding (null, length) import qualified Data.HVect as HV -import Web.Routing.AbstractRouter import Data.Maybe -import Data.List (foldl') -import Data.Monoid (Monoid (..)) -import Control.Applicative (Applicative (..), Alternative (..)) -import Data.String +#if MIN_VERSION_base(4,8,0) +import Data.Monoid ((<>)) +#else +import Data.Monoid (Monoid (..), (<>)) +import Control.Applicative ((<$>)) +#endif import Data.Typeable (Typeable) import Control.DeepSeq (NFData (..)) import Web.PathPieces @@ -24,155 +27,145 @@ import qualified Data.Text as T data RouteHandle m a - = forall as. RouteHandle (Path as) (HVectElim as (m a)) + = forall as. RouteHandle (PathInternal as) (HVectElim as (m a)) newtype HVectElim' x ts = HVectElim' { flipHVectElim :: HVectElim ts x } -data SafeRouter (m :: * -> *) a = SafeRouter +type Registry m a = (PathMap (m a), [[T.Text] -> m a]) -instance AbstractRouter (SafeRouter m a) where - 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, []) - rootPath = SafeRouterPath Empty - 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 - 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 - Empty :: Path '[] -- the empty path - StaticCons :: T.Text -> Path as -> Path as -- append a static path piece to path - VarCons :: (PathPiece a, Typeable a) => Path as -> Path (a ': as) -- append a param to path - -pathToRep :: Path as -> Rep as -pathToRep Empty = RNil -pathToRep (StaticCons _ p) = pathToRep p -pathToRep (VarCons p) = RCons (pathToRep p) +emptyRegistry :: Registry m a +emptyRegistry = (emptyPathMap, []) + +defRoute :: PathInternal xs -> HVectElim' (m a) xs -> Registry m a -> Registry m a +defRoute path action (m, call) = + ( insertPathMap (RouteHandle path (flipHVectElim action)) m + , call + ) + +fallbackRoute :: ([T.Text] -> m a) -> Registry m a -> Registry m a +fallbackRoute routeDef (m, call) = (m, call ++ [routeDef]) + +matchRoute :: Registry m a -> [T.Text] -> [m a] +matchRoute (m, cAll) pathPieces = + let matches = match m pathPieces + matches' = + if null matches + then matches ++ (map (\f -> f pathPieces) cAll) + else matches + in matches' + +data PathInternal (as :: [*]) where + PI_Empty :: PathInternal '[] -- the empty path + PI_StaticCons :: T.Text -> PathInternal as -> PathInternal as -- append a static path piece to path + PI_VarCons :: (PathPiece a, Typeable a) => PathInternal as -> PathInternal (a ': as) -- append a param to path + PI_Wildcard :: PathInternal as -> PathInternal (T.Text ': as) -- append the rest of the route data PathMap x = PathMap - { pm_here :: [x] + { pm_subComponents :: [[T.Text] -> x] + , pm_here :: [x] , pm_staticMap :: HM.HashMap T.Text (PathMap x) , pm_polyMap :: PM.PolyMap PathPiece PathMap x + , pm_wildcards :: [T.Text -> x] } instance Functor PathMap where - fmap f (PathMap h s p) = PathMap (fmap f h) (fmap (fmap f) s) (fmap f p) - -instance Applicative PathMap where - pure x = PathMap [x] mempty PM.empty - PathMap h s p <*> y = - let start = PathMap mempty (fmap (<*> y) s) (PM.updateAll (\a -> fmap flip a <*> y) p) - in foldl' (\pm f -> pm `mappend` fmap f y) start h - -instance Alternative PathMap where - empty = emptyPathMap - (<|>) = mappend + fmap f (PathMap c h s p w) = + PathMap (fmap f <$> c) (f <$> h) (fmap f <$> s) (f <$> p) (fmap f <$> w) instance NFData x => NFData (PathMap x) where - rnf (PathMap h s p) = rnf h `seq` rnf s `seq` PM.rnfHelper rnf p + rnf (PathMap c h s p w) = + rnf c `seq` rnf h `seq` rnf s `seq` PM.rnfHelper rnf p `seq` rnf w emptyPathMap :: PathMap x -emptyPathMap = PathMap mempty mempty PM.empty +emptyPathMap = PathMap mempty mempty mempty PM.empty mempty instance Monoid (PathMap x) where mempty = emptyPathMap - mappend (PathMap h1 s1 p1) (PathMap h2 s2 p2) = - PathMap (h1 `mappend` h2) (HM.unionWith mappend s1 s2) (PM.unionWith mappend p1 p2) + mappend (PathMap c1 h1 s1 p1 w1) (PathMap c2 h2 s2 p2 w2) = + PathMap (c1 <> c2) (h1 <> h2) (HM.unionWith (<>) s1 s2) (PM.unionWith (<>) p1 p2) (w1 <> w2) -insertPathMap' :: Path ts -> (HVect ts -> x) -> PathMap x -> PathMap x -insertPathMap' path action (PathMap h s p) = +updatePathMap + :: (forall y. (ctx -> y) -> PathMap y -> PathMap y) + -> PathInternal ts + -> (HVect ts -> ctx -> x) + -> PathMap x + -> PathMap x +updatePathMap updateFn path action pm@(PathMap c h s p w) = case path of - Empty -> PathMap (action HNil : h) s p - StaticCons pathPiece path' -> + PI_Empty -> updateFn (action HNil) pm + PI_StaticCons pathPiece path' -> let subPathMap = fromMaybe emptyPathMap (HM.lookup pathPiece s) - in PathMap h (HM.insert pathPiece (insertPathMap' path' action subPathMap) s) p - VarCons path' -> - let alterFn = Just . insertPathMap' path' (\vs v -> action (v :&: vs)) + in PathMap c h (HM.insert pathPiece (updatePathMap updateFn path' action subPathMap) s) p w + PI_VarCons path' -> + let alterFn = Just . updatePathMap updateFn path' (\vs ctx v -> action (v :&: vs) ctx) . fromMaybe emptyPathMap - in PathMap h s (PM.alter alterFn p) + in PathMap c h s (PM.alter alterFn p) w + PI_Wildcard PI_Empty -> + let (PathMap _ (action' : _) _ _ _) = updateFn (\ctx rest -> action (rest :&: HNil) ctx) emptyPathMap + in PathMap c h s p $ action' : w + PI_Wildcard _ -> error "Shouldn't happen" + +insertPathMap' :: PathInternal ts -> (HVect ts -> x) -> PathMap x -> PathMap x +insertPathMap' path action = + let updateHeres y (PathMap c h s p w) = PathMap c (y () : h) s p w + in updatePathMap updateHeres path (const <$> action) -singleton :: Path ts -> HVectElim ts x -> PathMap x +singleton :: PathInternal ts -> HVectElim ts x -> PathMap x singleton path action = insertPathMap' path (HV.uncurry action) mempty insertPathMap :: RouteHandle m a -> PathMap (m a) -> PathMap (m a) insertPathMap (RouteHandle path action) = insertPathMap' path (HV.uncurry action) +insertSubComponent' :: PathInternal ts -> (HVect ts -> [T.Text] -> x) -> PathMap x -> PathMap x +insertSubComponent' path subComponent = + let updateSubComponents y (PathMap c h s p w) = PathMap (y : c) h s p w + in updatePathMap updateSubComponents path subComponent + +insertSubComponent :: Functor m => RouteHandle m ([T.Text] -> a) -> PathMap (m a) -> PathMap (m a) +insertSubComponent (RouteHandle path comp) = + insertSubComponent' path (fmap (\m ps -> fmap ($ ps) m) (HV.uncurry comp)) + match :: PathMap x -> [T.Text] -> [x] -match (PathMap h _ _) [] = h -match (PathMap _ s p) (pp:pps) = - let staticMatches = maybeToList (HM.lookup pp s) >>= flip match pps - varMatches = PM.lookupConcat (fromPathPiece pp) - (\piece pathMap' -> fmap ($ piece) (match pathMap' pps)) p - in staticMatches ++ varMatches - --- | A route parameter -var :: (Typeable a, PathPiece a) => Path (a ': '[]) -var = VarCons Empty - -type Var a = Path (a ': '[]) - --- | A static route piece -static :: String -> Path '[] -static s = - let pieces = filter (not . T.null) $ T.splitOn "/" $ T.pack s - in foldr StaticCons Empty pieces - -instance (a ~ '[]) => IsString (Path a) where - fromString = static - --- | The root of a path piece. Use to define a handler for "/" -root :: Path '[] -root = Empty - -() :: Path as -> Path bs -> Path (Append as bs) -() Empty xs = xs -() (StaticCons pathPiece xs) ys = (StaticCons pathPiece (xs ys)) -() (VarCons xs) ys = (VarCons (xs ys)) - -renderRoute :: Path as -> HVect as -> T.Text -renderRoute p h = - T.intercalate "/" $ renderRoute' p h - -renderRoute' :: Path as -> HVect as -> [T.Text] -renderRoute' Empty _ = [] -renderRoute' (StaticCons pathPiece pathXs) paramXs = - ( pathPiece : renderRoute' pathXs paramXs ) -renderRoute' (VarCons pathXs) (val :&: paramXs) = - ( toPathPiece val : renderRoute' pathXs paramXs) -renderRoute' _ _ = - error "This will never happen." +match (PathMap c h s p w) pieces = + map ($ pieces) c ++ + case pieces of + [] -> h ++ fmap ($ "") w + (pp:pps) -> + let staticMatches = maybeToList (HM.lookup pp s) >>= flip match pps + varMatches = PM.lookupConcat (fromPathPiece pp) + (\piece pathMap' -> fmap ($ piece) (match pathMap' pps)) p + routeRest = combineRoutePieces pieces + wildcardMatches = fmap ($ routeRest) w + in staticMatches ++ varMatches ++ wildcardMatches + + +() :: PathInternal as -> PathInternal bs -> PathInternal (Append as bs) +() PI_Empty xs = xs +() (PI_StaticCons pathPiece xs) ys = PI_StaticCons pathPiece (xs ys) +() (PI_VarCons xs) ys = PI_VarCons (xs ys) +() (PI_Wildcard _) _ = error "Shouldn't happen" + +combineRoutePieces :: [T.Text] -> T.Text +combineRoutePieces = T.intercalate "/" -parse :: Path as -> [T.Text] -> Maybe (HVect as) -parse Empty [] = Just HNil +parse :: PathInternal as -> [T.Text] -> Maybe (HVect as) +parse PI_Empty [] = Just HNil parse _ [] = Nothing -parse path (pathComp : xs) = +parse path pathComps@(pathComp : xs) = case path of - Empty -> Nothing - StaticCons pathPiece pathXs -> + PI_Empty -> Nothing + PI_StaticCons pathPiece pathXs -> if pathPiece == pathComp then parse pathXs xs else Nothing - VarCons pathXs -> + PI_VarCons pathXs -> case fromPathPiece pathComp of Nothing -> Nothing Just val -> let finish = parse pathXs xs in fmap (\parsedXs -> val :&: parsedXs) finish + PI_Wildcard PI_Empty -> + Just $ (combineRoutePieces pathComps) :&: HNil + PI_Wildcard _ -> + error "Shouldn't happen" diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/reroute-0.3.1.0/src/Web/Routing/TextRouting.hs new/reroute-0.4.0.1/src/Web/Routing/TextRouting.hs --- old/reroute-0.3.1.0/src/Web/Routing/TextRouting.hs 2015-08-13 17:30:43.000000000 +0200 +++ new/reroute-0.4.0.1/src/Web/Routing/TextRouting.hs 1970-01-01 01:00:00.000000000 +0100 @@ -1,235 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TypeFamilies #-} -module Web.Routing.TextRouting where - -import Web.Routing.AbstractRouter - -import Data.String -import Control.DeepSeq (NFData (..)) -import qualified Data.Core.Graph as G -import qualified Data.HashMap.Strict as HM -import qualified Data.Text as T -import qualified Data.Vector as V -import qualified Data.Vector.Unboxed as VU -import qualified Data.Vector.Mutable as VM -import qualified Text.Regex as Regex - --- | Combine two routes, ensuring that the slashes don't get messed up -combineRoute :: T.Text -> T.Text -> T.Text -combineRoute r1 r2 = - case T.uncons r1 of - Nothing -> T.concat ["/", r2'] - Just ('/', _) -> T.concat [r1', r2'] - Just _ -> T.concat ["/", r1', r2'] - where - r1' = - if T.last r1 == '/' - then r1 - else if T.null r2 - then r1 - else T.concat [r1, "/"] - r2' = - if T.null r2 - then "" - else if T.head r2 == '/' then T.drop 1 r2 else r2 - -type TextAction m r = TAction m r '[] - -newtype TPath (a :: ()) - = TPath { unTPath :: T.Text } - deriving (Show, Eq, IsString, Read, Ord) - -newtype TAction m r (p :: [*]) - = TAction (m r) - -newtype TActionAppl m r - = TActionAppl (m r) - -data TextRouter (m :: * -> *) a = TextRouter - -instance AbstractRouter (TextRouter m a) where - 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, []) - rootPath = TextRouterPath "/" - 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 - { rw_regex :: !Regex.Regex - , rw_original :: !T.Text - } - -instance Eq RegexWrapper where - r1 == r2 = - rw_original r1 == rw_original r2 - -instance Show RegexWrapper where - show (RegexWrapper _ x) = show x - -instance NFData RegexWrapper where - rnf (RegexWrapper _ t) = rnf t - -data RouteNode - = RouteNodeRegex !CaptureVar !RegexWrapper - | RouteNodeCapture !CaptureVar - | RouteNodeText !T.Text - | RouteNodeRoot - deriving (Show, Eq) - -instance NFData RouteNode where - rnf (RouteNodeRegex v w) = rnf v `seq` rnf w - rnf (RouteNodeCapture v) = rnf v - rnf (RouteNodeText t) = rnf t - rnf RouteNodeRoot = () - -data RouteData a - = RouteData - { rd_node :: !RouteNode - , rd_data :: !(V.Vector a) - } - deriving (Show, Eq) - -instance NFData a => NFData (RouteData a) where - rnf (RouteData n d) = rnf n `seq` rnf d - -data RoutingTree a - = RoutingTree - { rm_graph :: G.Graph - , rm_nodeManager :: V.Vector (RouteData a) - , rm_rootNode :: G.Node - } deriving (Show, Eq) - -instance NFData a => NFData (RoutingTree a) where - rnf (RoutingTree g v r) = rnf g `seq` rnf v `seq` rnf r - -emptyRoutingTree :: RoutingTree a -emptyRoutingTree = - let rootNode = 0 - nodeManager = V.singleton (RouteData RouteNodeRoot V.empty) - in RoutingTree (G.addNode rootNode G.empty) nodeManager rootNode - -spawnNode :: G.Node -> RouteData a -> RoutingTree a -> (G.Node, RoutingTree a) -spawnNode parent nodeData rm = - let nm' = V.snoc (rm_nodeManager rm) nodeData - nodeId = (V.length nm') - 1 - g' = G.addNode nodeId (rm_graph rm) - g'' = G.addEdge parent nodeId g' - in (nodeId, RoutingTree g'' nm' (rm_rootNode rm)) - -addActionToNode :: G.Node -> a -> RoutingTree a -> RoutingTree a -addActionToNode nodeId nodeAction rm = - let routeDataOld = (rm_nodeManager rm) V.! nodeId - routeDataNew = - routeDataOld - { rd_data = V.snoc (rd_data routeDataOld) nodeAction - } - nm' = V.modify (\v -> VM.write v nodeId routeDataNew) (rm_nodeManager rm) - in rm { rm_nodeManager = nm' } - -addToRoutingTree :: T.Text -> a -> RoutingTree a -> RoutingTree a -addToRoutingTree route action origRm = - case chunks of - [] -> - addActionToNode (rm_rootNode origRm) action origRm - _ -> - treeTraversal (map parseRouteNode chunks) (rm_rootNode origRm) origRm - where - chunks = filter (not . T.null) $ T.splitOn "/" route - treeTraversal [] _ rm = rm - treeTraversal (node : xs) parentGraphNode rm = - let graph = rm_graph rm - children = G.children graph parentGraphNode - nm = rm_nodeManager rm - matchingChild = - VU.find (\nodeId -> node == rd_node (nm V.! nodeId)) children - in case matchingChild of - Just childId -> - treeTraversal xs childId (if null xs then addActionToNode childId action rm else rm) - Nothing -> - let (childId, rm') = - spawnNode parentGraphNode (RouteData node (if null xs then V.singleton action else V.empty)) rm - in treeTraversal xs childId rm' - -matchRoute :: T.Text -> RoutingTree a -> [(ParamMap, a)] -matchRoute route globalMap = - matchRoute' (T.splitOn "/" route) globalMap - -matchRoute' :: [T.Text] -> RoutingTree a -> [(ParamMap, a)] -matchRoute' routeParts globalRm = - findRoute (filter (not . T.null) routeParts) (rm_rootNode globalRm) emptyParamMap [] - where - globalGraph = rm_graph globalRm - nodeManager = rm_nodeManager globalRm - - findRoute [] parentId paramMap outMap = - outMap ++ (V.toList $ V.map (\action -> (paramMap, action)) (rd_data (nodeManager V.! parentId))) - findRoute (chunk : xs) parentId paramMap outMap = - let children = G.children globalGraph parentId - in VU.foldl' (\outV nodeId -> - case matchNode chunk (rd_node $ nodeManager V.! nodeId) of - (False, _) -> outV - (True, mCapture) -> - let paramMap' = - case mCapture of - Nothing -> paramMap - Just (var, val) -> - HM.insert var val paramMap - in (findRoute xs nodeId paramMap' outMap) ++ outV - ) [] children - -buildRegex :: T.Text -> RegexWrapper -buildRegex t = - RegexWrapper (Regex.mkRegex $ T.unpack t) t - -parseRouteNode :: T.Text -> RouteNode -parseRouteNode node = - case T.uncons node of - Just (':', var) -> - RouteNodeCapture $ CaptureVar var - Just ('{', rest) -> - case T.uncons (T.reverse rest) of - Just ('}', def) -> - let (var, xs) = T.breakOn ":" (T.reverse def) - in case T.uncons xs of - Just (':', regex) -> - RouteNodeRegex (CaptureVar var) (buildRegex regex) - _ -> - nodeError - _ -> nodeError - Just _ -> - RouteNodeText node - Nothing -> - nodeError - where - nodeError = error ("Spock route error: " ++ (show node) ++ " is not a valid route node.") - -emptyParamMap :: ParamMap -emptyParamMap = HM.empty - -matchNode :: T.Text -> RouteNode -> (Bool, Maybe (CaptureVar, T.Text)) -matchNode _ RouteNodeRoot = (False, Nothing) -matchNode t (RouteNodeText m) = (m == t, Nothing) -matchNode t (RouteNodeCapture var) = (True, Just (var, t)) -matchNode t (RouteNodeRegex var regex) = - case Regex.matchRegex (rw_regex regex) (T.unpack t) of - Nothing -> (False, Nothing) - Just _ -> (True, Just (var, t)) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/reroute-0.3.1.0/test/Web/Routing/SafeRoutingSpec.hs new/reroute-0.4.0.1/test/Web/Routing/SafeRoutingSpec.hs --- old/reroute-0.3.1.0/test/Web/Routing/SafeRoutingSpec.hs 2015-08-13 17:30:43.000000000 +0200 +++ new/reroute-0.4.0.1/test/Web/Routing/SafeRoutingSpec.hs 2016-08-25 13:02:10.000000000 +0200 @@ -8,10 +8,12 @@ import Data.HVect hiding (singleton) import Control.Monad.Identity +import Control.Monad.RWS.Strict +import Data.Maybe +import Web.Routing.Combinators +import Web.Routing.Router import Web.Routing.SafeRouting -import Web.Routing.AbstractRouter -import Data.Monoid (mconcat) -import Control.Applicative (Applicative (..)) +import qualified Data.HashMap.Strict as HM import qualified Data.Text as T data ReturnVar @@ -21,8 +23,29 @@ | 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) +defR :: (Monad m, m ReturnVar ~ x) => Path ts ps -> HVectElim ts x -> RegistryT m ReturnVar middleware Bool m () +defR path action = hookRoute True (toInternalPath path) (HVectElim' action) + +-- TODO: abstract this code, move into AbstractRouter +defSubComponent :: + ( Monad m +#if __GLASGOW_HASKELL__ <= 708 + , Functor m +#endif + , m ([T.Text] -> ReturnVar) ~ x + ) + => Path ts ps + -> HVectElim ts x + -> RegistryT m ReturnVar middleware Bool m () +defSubComponent path comp = + do let reqType = True + basePath <- ask + modify $ \rs -> + rs { rs_registry = + let (reg, fb) = fromMaybe emptyRegistry (HM.lookup reqType (rs_registry rs)) + reg' = insertSubComponent (RouteHandle (basePath toInternalPath path) comp) reg + in HM.insert reqType (reg', fb) (rs_registry rs) + } spec :: Spec spec = @@ -43,25 +66,14 @@ 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 it "should have a catch all route" $ do checkRoute "/aslkdjk/asdaskl/aslkjd" [StrVar "aslkdjk/asdaskl/aslkjd"] checkRoute "/zuiasf/zuiasf" [StrVar "zuiasf/zuiasf"] + it "should hand over remaining path pieces to subcomponents" $ + do checkRoute "/subcomponent/blog/foo/bar/nanana" [StrVar "blog:foo?bar?nanana"] + it "should handle wildcard routes" $ + do checkRoute "/wildcard/" [StrVar ""] + checkRoute "/wildcard/some/additional/data" [StrVar "some/additional/data"] where pieces :: T.Text -> [T.Text] pieces = filter (not . T.null) . T.splitOn "/" @@ -69,12 +81,11 @@ checkRoute :: T.Text -> [ReturnVar] -> Expectation checkRoute r x = let matches = handleFun (pieces r) - in (map (runIdentity . snd) matches) `shouldBe` x + in (map runIdentity matches) `shouldBe` x - handleFun :: [T.Text] -> [(ParamMap, Identity ReturnVar)] + handleFun :: [T.Text] -> [Identity ReturnVar] handleFun = handleFun' True - (_, handleFun', _) = - runIdentity (runRegistry SafeRouter handleDefs) + (_, handleFun', _) = runIdentity (runRegistry handleDefs) handleDefs = do defR root $ return (StrVar "root") @@ -94,4 +105,8 @@ defR ("bar" "bingo") $ return (StrVar "bar/bingo") defR ("bar" var) $ (return . StrVar . T.pack) defR ("entry" var "audit") (return . IntVar) + defSubComponent ("subcomponent" var) $ \name -> + return $ \ps -> StrVar $ name <> ":" <> T.intercalate "?" ps + defR ("wildcard" wildcard) $ \rest -> + return $ StrVar rest hookAny True (return . StrVar . T.intercalate "/") diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/reroute-0.3.1.0/test/Web/Routing/TextRoutingSpec.hs new/reroute-0.4.0.1/test/Web/Routing/TextRoutingSpec.hs --- old/reroute-0.3.1.0/test/Web/Routing/TextRoutingSpec.hs 2015-08-13 17:30:43.000000000 +0200 +++ new/reroute-0.4.0.1/test/Web/Routing/TextRoutingSpec.hs 1970-01-01 01:00:00.000000000 +0100 @@ -1,83 +0,0 @@ -{-# 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 - matchRoute "/baz/" routingTree `shouldBe` noMatches - it "should match known routes" $ - do matchRoute "/" routingTree `shouldBe` oneMatch emptyParamMap [1] - 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]$")