reroute 0.3.1.0 → 0.4.0.0
raw patch · 10 files changed
+347/−590 lines, 10 filesdep −transformersdep ~graph-coredep ~regex-compatdep ~vector
Dependencies removed: transformers
Dependency ranges changed: graph-core, regex-compat, vector
Files
- README.md +2/−2
- reroute.cabal +7/−12
- src/Data/PolyMap.hs +6/−1
- src/Web/Routing/AbstractRouter.hs +0/−123
- src/Web/Routing/Combinators.hs +78/−0
- src/Web/Routing/Router.hs +112/−0
- src/Web/Routing/SafeRouting.hs +102/−109
- src/Web/Routing/TextRouting.hs +0/−235
- test/Web/Routing/SafeRoutingSpec.hs +40/−25
- test/Web/Routing/TextRoutingSpec.hs +0/−83
README.md view
@@ -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`+* From Source: `git clone https://github.com/agrafix/Spock.git && cd Spock/reroute && cabal install`
reroute.cabal view
@@ -1,13 +1,13 @@ name: reroute-version: 0.3.1.0+version: 0.4.0.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+homepage: http://github.com/agrafix/Spock license: MIT license-file: LICENSE author: Alexander Thiemann <mail@athiemann.net>, Tim Baumann <tim@timbaumann.info> maintainer: Alexander Thiemann <mail@athiemann.net>-copyright: (c) 2014 - 2015 Alexander Thiemann <mail@athiemann.net>, Tim Baumann <tim@timbaumann.info>+copyright: (c) 2014 - 2016 Alexander Thiemann <mail@athiemann.net>, Tim Baumann <tim@timbaumann.info> category: Web build-type: Simple cabal-version: >=1.10@@ -18,21 +18,17 @@ library exposed-modules: Data.PolyMap,- Web.Routing.AbstractRouter,+ Web.Routing.Router, Web.Routing.SafeRouting,- Web.Routing.TextRouting+ 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,8 +40,7 @@ hs-source-dirs: test main-is: Spec.hs other-modules:- Web.Routing.SafeRoutingSpec,- Web.Routing.TextRoutingSpec+ Web.Routing.SafeRoutingSpec build-depends: base, hspec,@@ -81,4 +76,4 @@ source-repository head type: git- location: git://github.com/agrafix/reroute.git+ location: git://github.com/agrafix/Spock.git
src/Data/PolyMap.hs view
@@ -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
− src/Web/Routing/AbstractRouter.hs
@@ -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- }
+ src/Web/Routing/Combinators.hs view
@@ -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
+ src/Web/Routing/Router.hs view
@@ -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+ }
src/Web/Routing/SafeRouting.hs view
@@ -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'+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+ ) -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+fallbackRoute :: ([T.Text] -> m a) -> Registry m a -> Registry m a+fallbackRoute routeDef (m, call) = (m, call ++ [routeDef]) -pathToRep :: Path as -> Rep as-pathToRep Empty = RNil-pathToRep (StaticCons _ p) = pathToRep p-pathToRep (VarCons p) = RCons (pathToRep p)+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" -singleton :: Path ts -> HVectElim ts x -> PathMap x+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 :: 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) -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+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 --- | A route parameter-var :: (Typeable a, PathPiece a) => Path (a ': '[])-var = VarCons Empty+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)) -type Var a = Path (a ': '[])+match :: PathMap x -> [T.Text] -> [x]+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 --- | 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+(</!>) :: 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" -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."+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"
− src/Web/Routing/TextRouting.hs
@@ -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))
test/Web/Routing/SafeRoutingSpec.hs view
@@ -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,9 +23,30 @@ | 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 = describe "SafeRouting 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 "/")
− test/Web/Routing/TextRoutingSpec.hs
@@ -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]$")