diff --git a/reroute.cabal b/reroute.cabal --- a/reroute.cabal +++ b/reroute.cabal @@ -1,5 +1,5 @@ name: reroute -version: 0.1.0.0 +version: 0.2.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 @@ -13,18 +13,20 @@ cabal-version: >=1.10 library - exposed-modules: Web.Routing.AbstractRouter, Web.Routing.SafeRouting, Web.Routing.TextRouting + exposed-modules: Data.HVect, Web.Routing.AbstractRouter, Web.Routing.SafeRouting, Web.Routing.TextRouting + other-modules: Data.PolyMap build-depends: base >=4.6 && <4.8, transformers >=0.3 && <0.5, text >= 0.11.3.1 && <1.3, unordered-containers ==0.2.*, - HList >=0.3, regex-compat ==0.95.*, 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 + vector >=0.10 && <0.11, + deepseq >= 1.1.0.2 && < 1.4, + graph-core >=0.2 && <0.3 hs-source-dirs: src default-language: Haskell2010 @@ -38,13 +40,14 @@ transformers >=0.3 && <0.5, text >= 0.11.3.1 && <1.3, unordered-containers ==0.2.*, - HList >=0.3, regex-compat ==0.95.*, 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 + vector >=0.10 && <0.11, + deepseq >= 1.1.0.2 && < 1.4, + graph-core >=0.2 && <0.3 default-language: Haskell2010 ghc-options: -Wall -fno-warn-orphans diff --git a/src/Data/HVect.hs b/src/Data/HVect.hs new file mode 100644 --- /dev/null +++ b/src/Data/HVect.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE UndecidableInstances #-} -- for ReverseLoop type family +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} + +module Data.HVect + ( HVect (..) + , HVectElim + , Append, hVectAppend + , ReverseLoop, Reverse, hVectReverse + , hVectUncurry + , Rep (..), HasRep (..) + , hVectCurryExpl, hVectCurry + , packExpl, pack + ) where + +data HVect (ts :: [*]) where + HNil :: HVect '[] + HCons :: t -> HVect ts -> HVect (t ': ts) + +-- todo: use a closed type family once GHC 7.6 compatibility is dropped +type family HVectElim (ts :: [*]) (a :: *) :: * +type instance HVectElim '[] a = a +type instance HVectElim (t ': ts) a = t -> HVectElim ts a + +-- todo: use a closed type family once GHC 7.6 compatibility is dropped +type family Append (as :: [*]) (bs :: [*]) :: [*] +type instance Append '[] bs = bs +type instance Append (a ': as) bs = a ': (Append as bs) + +hVectAppend :: HVect as -> HVect bs -> HVect (Append as bs) +hVectAppend HNil bs = bs +hVectAppend (HCons a as) bs = HCons a (hVectAppend as bs) + +type family ReverseLoop (as :: [*]) (bs :: [*]) :: [*] +type instance ReverseLoop '[] bs = bs +type instance ReverseLoop (a ': as) bs = ReverseLoop as (a ': bs) + +type Reverse as = ReverseLoop as '[] + +hVectReverse :: HVect as -> HVect (Reverse as) +hVectReverse vs = go vs HNil + where + go :: HVect as -> HVect bs -> HVect (ReverseLoop as bs) + go HNil bs = bs + go (HCons a as) bs = go as (HCons a bs) + +hVectUncurry :: HVectElim ts a -> HVect ts -> a +hVectUncurry f HNil = f +hVectUncurry f (HCons x xs) = hVectUncurry (f x) xs + +data Rep (ts :: [*]) where + RNil :: Rep '[] + RCons :: Rep ts -> Rep (t ': ts) + +class HasRep (ts :: [*]) where + hasRep :: Rep ts + +instance HasRep '[] where + hasRep = RNil + +instance HasRep ts => HasRep (t ': ts) where + hasRep = RCons hasRep + +hVectCurryExpl :: Rep ts -> (HVect ts -> a) -> HVectElim ts a +hVectCurryExpl RNil f = f HNil +hVectCurryExpl (RCons r) f = \x -> hVectCurryExpl r (f . HCons x) + +hVectCurry :: HasRep ts => (HVect ts -> a) -> HVectElim ts a +hVectCurry = hVectCurryExpl hasRep + +buildElim :: Rep ts -> (HVect ts -> HVect ss) -> HVectElim ts (HVect ss) +buildElim RNil f = f HNil +buildElim (RCons r) f = \x -> buildElim r (f . HCons x) + +packExpl :: Rep ts -> (forall a. HVectElim ts a -> a) -> HVect ts +packExpl rep f = f (buildElim rep id) + +pack :: HasRep ts => (forall a. HVectElim ts a -> a) -> HVect ts +pack = packExpl hasRep diff --git a/src/Data/PolyMap.hs b/src/Data/PolyMap.hs new file mode 100644 --- /dev/null +++ b/src/Data/PolyMap.hs @@ -0,0 +1,194 @@ +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE GADTs #-} + +module Data.PolyMap + ( PolyMap, empty, rnfHelper + , lookup, lookupApply, lookupApplyAll, lookupConcat + , alter, updateAll, insertWith + , unionWith, union + , zipWith', zipWith, zip, ap + ) where + +import Prelude hiding (lookup, zipWith, zip) +import Data.Typeable +import Control.Applicative (Applicative (..), Alternative ((<|>)), liftA2) +import Data.Monoid (Monoid (..)) +import GHC.Exts (Constraint) + +data PolyMap (c :: * -> Constraint) (f :: * -> *) (a :: *) where + PMNil :: PolyMap c f a + PMCons :: (Typeable p, c p) => f (p -> a) -> PolyMap c f a -> PolyMap c f a + +instance Functor f => Functor (PolyMap c f) where + fmap _ PMNil = PMNil + fmap f (PMCons v pm) = PMCons (fmap ((.) f) v) (fmap f pm) + +instance Alternative f => Monoid (PolyMap c f a) where + mempty = empty + mappend = union + +empty :: PolyMap c f a +empty = PMNil + +rnfHelper :: (forall p. c p => f (p -> a) -> ()) -> PolyMap c f a -> () +rnfHelper _ PMNil = () +rnfHelper h (PMCons v pm) = h v `seq` rnfHelper h pm + +lookup :: + Typeable p + => PolyMap c f a + -> Maybe (f (p -> a)) +lookup PMNil = Nothing +lookup (PMCons w polyMap') = + case gcast1 w of + Just w' -> Just w' + Nothing -> lookup polyMap' + +lookupApply :: + (Typeable p, Functor f) + => p + -> PolyMap c f a + -> Maybe (f a) +lookupApply _ PMNil = Nothing +lookupApply p (PMCons w polyMap') = + case gcast1 w of + Just w' -> Just (fmap ($ p) w') + Nothing -> lookupApply p polyMap' + +lookupApplyAll :: + Functor f + => (forall p. c p => Maybe p) + -> PolyMap c f a + -> [f a] +lookupApplyAll maybeGet polyMap = + case polyMap of + PMNil -> [] + PMCons w polyMap' -> + let rest = lookupApplyAll maybeGet polyMap' + in case maybeGet of + Nothing -> rest + Just p -> (fmap ($ p) w) : rest + +lookupConcat :: + (Monoid m, Functor f) + => (forall p. c p => Maybe p) + -> (forall p. c p => p -> f (p -> a) -> m) + -> PolyMap c f a + -> m +lookupConcat maybeGet comp polyMap = + case polyMap of + PMNil -> mempty + PMCons w polyMap' -> + let rest = lookupConcat maybeGet comp polyMap' + in case maybeGet of + Nothing -> rest + Just p -> comp p w `mappend` rest + + +maybeInsertHere :: + (c p, Typeable p) + => Maybe (f (p -> a)) + -> PolyMap c f a + -> PolyMap c f a +maybeInsertHere = maybe id PMCons + +alter :: + (Typeable p, c p) + => (Maybe (f (p -> a)) -> Maybe (f (p -> a))) + -> PolyMap c f a + -> PolyMap c f a +alter (g :: Maybe (f (p -> a)) -> Maybe (f (p -> a))) polyMap = + case polyMap of + PMNil -> insertHere PMNil + PMCons (w :: f (q -> a)) polyMap' -> + case gcast1 w of + Just w' -> + case g (Just w') of + Just w'' -> PMCons w'' polyMap' + Nothing -> polyMap' + Nothing -> + if typeOf (undefined :: p) < typeOf (undefined :: q) + then insertHere polyMap + else PMCons w (alter g polyMap') + where insertHere = maybe id PMCons (g Nothing) + +updateAll :: + (forall p. c p => f (p -> a) -> g (p -> b)) + -> PolyMap c f a + -> PolyMap c g b +updateAll _ PMNil = PMNil +updateAll f (PMCons v pm) = PMCons (f v) (updateAll f pm) + +insertWith :: + (Typeable p, c p) + => (f (p -> a) -> f (p -> a) -> f (p -> a)) + -> f (p -> a) + -> PolyMap c f a + -> PolyMap c f a +insertWith combine val = alter (Just . maybe val (combine val)) + +unionWith :: + (forall p. c p => f (p -> a) -> f (p -> a) -> f (p -> a)) + -> PolyMap c f a + -> PolyMap c f a + -> PolyMap c f a +unionWith _ PMNil pm2 = pm2 +unionWith _ pm1 PMNil = pm1 +unionWith combine pm1@(PMCons (v :: f (p -> a)) pm1') + pm2@(PMCons (w :: f (q -> a)) pm2') = + case gcast1 v of + Just v' -> PMCons (combine v' w) (unionWith combine pm1' pm2') + Nothing -> + if typeOf (undefined :: p) < typeOf (undefined :: q) + then PMCons v (unionWith combine pm1' pm2) + else PMCons w (unionWith combine pm1 pm2') + +union :: + Alternative f + => PolyMap c f a + -> PolyMap c f a + -> PolyMap c f a +union = unionWith (<|>) + +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 + -> PolyMap c f d +zipWith' f = go + where + go PMNil PMNil = PMNil + go PMNil (PMCons w pm2') = maybeInsertHere (f Nothing (Just w)) (go PMNil pm2') + go (PMCons v pm1') PMNil = maybeInsertHere (f (Just v) Nothing) (go pm1' PMNil) + go pm1@(PMCons (v :: f (p -> a)) pm1') pm2@(PMCons (w :: f (q -> b)) pm2') = + case gcast1 v of + Just v' -> maybeInsertHere (f (Just v') (Just w)) (go pm1 pm2) + Nothing -> + if typeOf (undefined :: p) < typeOf (undefined :: q) + then maybeInsertHere (f (Just v) Nothing) (go pm1' pm2) + else maybeInsertHere (f Nothing (Just w)) (go pm1 pm2') + +zipWith :: + Applicative f + => (a -> b -> d) + -> PolyMap c f a + -> PolyMap c f b + -> PolyMap c f d +zipWith f = zipWith' $ liftA2 $ liftA2 $ \a b p -> f (a p) (b p) + +zip :: + Applicative f + => PolyMap c f a + -> PolyMap c f b + -> PolyMap c f (a, b) +zip = zipWith (,) + +ap :: + Applicative f + => PolyMap c f (a -> b) + -> PolyMap c f a + -> PolyMap c f b +ap = zipWith ($) diff --git a/src/Web/Routing/AbstractRouter.hs b/src/Web/Routing/AbstractRouter.hs --- a/src/Web/Routing/AbstractRouter.hs +++ b/src/Web/Routing/AbstractRouter.hs @@ -10,6 +10,7 @@ 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 :: * @@ -26,7 +27,7 @@ newtype CaptureVar = CaptureVar { unCaptureVar :: T.Text } - deriving (Show, Eq, Hashable) + deriving (Show, Eq, Hashable, NFData) newtype RegistryT r middleware reqTypes (m :: * -> *) a = RegistryT { runRegistryT :: RWST (RoutePath r '[]) [middleware] (RegistryState r reqTypes) m a } @@ -48,12 +49,13 @@ -> RouteAction r as -> RegistryT r middleware reqTypes m () hookRoute reqType path action = - modify $ \rs -> - rs { rs_registry = - let reg = fromMaybe emptyRegistry (HM.lookup reqType (rs_registry rs)) - reg' = defRoute path action reg - in HM.insert reqType reg' (rs_registry rs) - } + 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 diff --git a/src/Web/Routing/SafeRouting.hs b/src/Web/Routing/SafeRouting.hs --- a/src/Web/Routing/SafeRouting.hs +++ b/src/Web/Routing/SafeRouting.hs @@ -1,32 +1,38 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} + module Web.Routing.SafeRouting where +import qualified Data.PolyMap as PM +import Data.HVect import Web.Routing.AbstractRouter -import Data.HList import Data.Maybe -import Data.Monoid +import Data.List (foldl') +import Data.Monoid (Monoid (..)) +import Control.Applicative (Applicative (..), Alternative (..)) import Data.String +import Data.Typeable (Typeable) +import Control.DeepSeq (NFData (..)) import Web.PathPieces import qualified Data.HashMap.Strict as HM import qualified Data.Text as T data RouteHandle m a - = forall as. RouteHandle (Path as) (HListElim as (m a)) + = forall as. RouteHandle (Path as) (HVectElim as (m a)) -newtype HListElim' x ts = HListElim' { flipHListElim :: HListElim ts x } +newtype HVectElim' x ts = HVectElim' { flipHVectElim :: HVectElim ts x } data SafeRouter (m :: * -> *) a = SafeRouter instance AbstractRouter (SafeRouter m a) where newtype Registry (SafeRouter m a) = SafeRouterReg (PathMap (m a)) newtype RoutePath (SafeRouter m a) xs = SafeRouterPath (Path xs) - type RouteAction (SafeRouter m a) = HListElim' (m a) + type RouteAction (SafeRouter m a) = HVectElim' (m a) type RouteAppliedAction (SafeRouter m a) = m a subcompCombine (SafeRouterPath p1) (SafeRouterPath p2) = SafeRouterPath $ @@ -35,81 +41,72 @@ rootPath = SafeRouterPath Empty defRoute (SafeRouterPath path) action (SafeRouterReg m) = SafeRouterReg $ - insertPathMap (RouteHandle path (flipHListElim action)) m + insertPathMap (RouteHandle path (flipHVectElim action)) m matchRoute (SafeRouterReg m) pathPieces = let matches = match m pathPieces in zip (replicate (length matches) HM.empty) matches -type family HListElim (ts :: [*]) (a :: *) :: * -type instance HListElim '[] a = a -type instance HListElim (t ': ts) a = t -> HListElim ts a -hListUncurry :: HListElim ts a -> HList ts -> a -hListUncurry f HNil = f -hListUncurry f (HCons x xs) = hListUncurry (f x) xs - 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 -data PolyMap x where - PMNil :: PolyMap x - PMCons :: (Typeable a, PathPiece a) => PathMap (a -> x) -> PolyMap x -> PolyMap x - -data Id a = Id { getId :: a } - -castDefType :: (Typeable a, Typeable b) => (a -> c) -> Maybe (b -> c) -castDefType x = fmap getId (gcast1 (Id x)) - -insertPolyMap :: - (Typeable a, PathPiece a) - => Path ts - -> (a -> HList ts -> x) - -> PolyMap x - -> PolyMap x -insertPolyMap path (action :: a -> HList ts -> x) polyMap = - case polyMap of - PMNil -> PMCons (insertPathMap' path (flip action) emptyPathMap) PMNil - PMCons (pathMap :: PathMap (b -> x)) polyMap' -> - case castDefType action of - Just action' -> - PMCons (insertPathMap' path (flip action') pathMap) polyMap' - Nothing -> - PMCons pathMap (insertPolyMap path action polyMap') +data PathMap x = + PathMap + { pm_here :: [x] + , pm_staticMap :: HM.HashMap T.Text (PathMap x) + , pm_polyMap :: PM.PolyMap PathPiece PathMap x + } -lookupPolyMap :: T.Text -> [T.Text] -> PolyMap x -> [x] -lookupPolyMap _ _ PMNil = [] -lookupPolyMap pp pps (PMCons pathMap polyMap') = - (maybeToList (fromPathPiece pp) >>= \val -> fmap ($ val) (match pathMap pps)) - ++ lookupPolyMap pp pps polyMap' +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 -emptyPolyMap :: PolyMap x -emptyPolyMap = PMNil +instance Alternative PathMap where + empty = emptyPathMap + (<|>) = mappend -data PathMap x = PathMap [x] (HM.HashMap T.Text (PathMap x)) (PolyMap x) +instance NFData x => NFData (PathMap x) where + rnf (PathMap h s p) = rnf h `seq` rnf s `seq` PM.rnfHelper rnf p emptyPathMap :: PathMap x -emptyPathMap = PathMap mempty mempty emptyPolyMap +emptyPathMap = PathMap mempty mempty PM.empty -insertPathMap' :: Path ts -> (HList ts -> x) -> PathMap x -> PathMap x -insertPathMap' path action (PathMap as m pm) = +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) + +insertPathMap' :: Path ts -> (HVect ts -> x) -> PathMap x -> PathMap x +insertPathMap' path action (PathMap h s p) = case path of - Empty -> PathMap (action HNil : as) m pm - StaticCons pathPiece xs -> - let subPathMap = fromMaybe emptyPathMap (HM.lookup pathPiece m) - in PathMap as (HM.insert pathPiece (insertPathMap' xs action subPathMap) m) pm - VarCons xs -> PathMap as m (insertPolyMap xs (\v vs -> action (HCons v vs)) pm) + Empty -> PathMap (action HNil : h) s p + 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 (HCons v vs)) + . fromMaybe emptyPathMap + in PathMap h s (PM.alter alterFn p) +singleton :: Path ts -> HVectElim ts x -> PathMap x +singleton path action = insertPathMap' path (hVectUncurry action) mempty + insertPathMap :: RouteHandle m a -> PathMap (m a) -> PathMap (m a) -insertPathMap (RouteHandle path action) = insertPathMap' path (hListUncurry action) +insertPathMap (RouteHandle path action) = insertPathMap' path (hVectUncurry action) match :: PathMap x -> [T.Text] -> [x] -match (PathMap as _ _) [] = as -match (PathMap _ m pm) (pp:pps) = - let staticMatches = maybeToList (HM.lookup pp m) >>= flip match pps - varMatches = lookupPolyMap pp pps pm +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 @@ -120,7 +117,9 @@ -- | A static route piece static :: String -> Path '[] -static s = StaticCons (T.pack s) Empty +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 @@ -129,16 +128,16 @@ root :: Path '[] root = Empty -() :: Path as -> Path bs -> Path (HAppendList as bs) +() :: 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 -> HList as -> T.Text +renderRoute :: Path as -> HVect as -> T.Text renderRoute p h = T.intercalate "/" $ renderRoute' p h -renderRoute' :: Path as -> HList as -> [T.Text] +renderRoute' :: Path as -> HVect as -> [T.Text] renderRoute' Empty _ = [] renderRoute' (StaticCons pathPiece pathXs) paramXs = ( pathPiece : renderRoute' pathXs paramXs ) @@ -147,7 +146,7 @@ renderRoute' _ _ = error "This will never happen." -parse :: Path as -> [T.Text] -> Maybe (HList as) +parse :: Path as -> [T.Text] -> Maybe (HVect as) parse Empty [] = Just HNil parse _ [] = Nothing parse path (pathComp : xs) = diff --git a/src/Web/Routing/Specs/SafeRoutingSpec.hs b/src/Web/Routing/Specs/SafeRoutingSpec.hs --- a/src/Web/Routing/Specs/SafeRoutingSpec.hs +++ b/src/Web/Routing/Specs/SafeRoutingSpec.hs @@ -8,10 +8,13 @@ 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 @@ -21,14 +24,14 @@ | ListVar [ReturnVar] deriving (Show, Eq, Read) -defR :: (Monad m, HListElim ts (m ReturnVar) ~ HListElim ts x) => Path ts -> HListElim ts x -> RegistryT (SafeRouter m ReturnVar) middleware Bool m () -defR path action = hookRoute True (SafeRouterPath path) (HListElim' action) +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 "shoud match known routes" $ + do it "should match known routes" $ do checkRoute "" [StrVar "root"] checkRoute "/bar" [StrVar "bar"] it "shoudn't match unknown routes" $ @@ -45,10 +48,29 @@ 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 (filter (not . T.null) $ T.splitOn "/" r) + let matches = handleFun (pieces r) in (map (runIdentity . snd) matches) `shouldBe` x handleFun :: [T.Text] -> [(ParamMap, Identity ReturnVar)] @@ -67,7 +89,7 @@ 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 -> + 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]) diff --git a/src/Web/Routing/Specs/TextRoutingSpec.hs b/src/Web/Routing/Specs/TextRoutingSpec.hs --- a/src/Web/Routing/Specs/TextRoutingSpec.hs +++ b/src/Web/Routing/Specs/TextRoutingSpec.hs @@ -5,7 +5,6 @@ import Web.Routing.TextRouting import qualified Web.Routing.AbstractRouter as R -import qualified Data.Vector as V import qualified Data.HashMap.Strict as HM spec :: Spec @@ -13,7 +12,6 @@ do matchNodeDesc matchRouteDesc parseRouteNodeDesc - addToRoutingTreeDesc matchNodeDesc :: Spec matchNodeDesc = @@ -52,8 +50,8 @@ ((oneMatch emptyParamMap [5]) ++ oneMatch (vMap [("baz", "bingo")]) [3]) multiMatch' = - ((oneMatch (vMap [("since", "audit"), ("cid", "1")]) [6]) - ++ (oneMatch (vMap [("eid", "1")]) [8])) + ((oneMatch (vMap [("eid", "1")]) [8]) + ++ (oneMatch (vMap [("since", "audit"), ("cid", "1")]) [6])) noMatches = [] oneMatch pm m = [(pm, m)] routingTree = @@ -81,30 +79,3 @@ parseRouteNode ":bar" `shouldBe` RouteNodeCapture (R.CaptureVar "bar") it "parses regex capture variables" $ parseRouteNode "{bar:^[0-9]$}" `shouldBe` RouteNodeRegex (R.CaptureVar "bar") (buildRegex "^[0-9]$") - -addToRoutingTreeDesc :: Spec -addToRoutingTreeDesc = - describe "addToRoutingTree" $ - do it "adds the root node correctly" $ - addToRoutingTree "/" [True] emptyT `shouldBe` baseRoute - it "adds a new branch correctly" $ - addToRoutingTree "/foo/:bar" [True] emptyT `shouldBe` fooBar [] - it "add a new subbranch correctly" $ - addToRoutingTree "/foo/:bar/baz" [True] (fooBar []) `shouldBe` fooBar baz - where - emptyT = emptyRoutingTree - baseRoute = RoutingTree { rt_node = RouteData{rd_node = RouteNodeRoot, rd_data = Just [True]}, rt_children = V.empty} - baz = [ RoutingTree { rt_node = RouteData { rd_node = RouteNodeText "baz", rd_data = Just [True] },rt_children = V.empty }] - fooBar xs = - RoutingTree - { rt_node = - RouteData {rd_node = RouteNodeRoot, rd_data = Nothing } - , rt_children = - V.fromList - [ RoutingTree { rt_node = RouteData{rd_node = RouteNodeText "foo", rd_data = Nothing} - , rt_children = - V.fromList - [ RoutingTree { rt_node = RouteData { rd_node = RouteNodeCapture (R.CaptureVar "bar") - , rd_data = Just [True] - } - , rt_children = V.fromList xs}]}]} diff --git a/src/Web/Routing/TextRouting.hs b/src/Web/Routing/TextRouting.hs --- a/src/Web/Routing/TextRouting.hs +++ b/src/Web/Routing/TextRouting.hs @@ -7,11 +7,13 @@ import Web.Routing.AbstractRouter -import Data.Maybe import Data.String +import Control.DeepSeq (NFData (..)) +import qualified Data.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 @@ -76,6 +78,9 @@ 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 @@ -83,62 +88,111 @@ | 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 :: Maybe a + , 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 - { rt_node :: !(RouteData a) - , rt_children :: !(V.Vector (RoutingTree a)) - } - deriving (Show, Eq) + { rm_graph :: G.Graph + , rm_nodeManager :: V.Vector (RouteData a) + , rm_rootNode :: G.Node + } deriving (Show, Eq) -buildRegex :: T.Text -> RegexWrapper -buildRegex t = - RegexWrapper (Regex.mkRegex $ T.unpack t) t +instance NFData a => NFData (RoutingTree a) where + rnf (RoutingTree g v r) = rnf g `seq` rnf v `seq` rnf r emptyRoutingTree :: RoutingTree a emptyRoutingTree = - RoutingTree (RouteData RouteNodeRoot Nothing) V.empty + let rootNode = 0 + nodeManager = V.singleton (RouteData RouteNodeRoot V.empty) + in RoutingTree (G.addNode rootNode G.empty) nodeManager rootNode -mergeData :: Maybe a -> Maybe a -> Maybe a -mergeData (Just _) (Just _) = - error "Spock error: Don't define the same route twice!" -mergeData (Just a) _ = Just a -mergeData _ (Just b) = Just b -mergeData _ _ = Nothing +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 dat currTree = - let applyTree [] tree = tree - applyTree (current:xs) tree = - let children = V.map (\(RoutingTree d _) -> rd_node d) (rt_children tree) - currentDat = - case xs of - [] -> Just dat - _ -> Nothing - children' = - case V.findIndex (==current) children of - Nothing -> - let h = applyTree xs $ RoutingTree (RouteData current currentDat) V.empty - in V.cons h (rt_children tree) - Just idx -> - let origNode = (V.!) (rt_children tree) idx - matchingNode = rt_node $ origNode - appliedNode = matchingNode { rd_data = mergeData (rd_data matchingNode) currentDat } - in V.modify (\v -> VM.write v idx (applyTree xs $ RoutingTree appliedNode (rt_children origNode))) (rt_children tree) - in tree { rt_children = children' } - in case filter (not . T.null) $ T.splitOn "/" route of - [] -> - let currNode = rt_node currTree - currNode' = currNode { rd_data = mergeData (rd_data currNode) (Just dat) } - in currTree { rt_node = currNode' } - xs -> applyTree (map parseRouteNode xs) currTree +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 @@ -163,48 +217,6 @@ emptyParamMap :: ParamMap emptyParamMap = HM.empty - -matchRoute :: T.Text -> RoutingTree a -> [(ParamMap, a)] -matchRoute route globalTree = - matchRoute' (T.splitOn "/" route) globalTree - -matchRoute' :: [T.Text] -> RoutingTree a -> [(ParamMap, a)] -matchRoute' routeParts globalTree = - case filter (not . T.null) routeParts of - [] -> - case rd_data $ rt_node globalTree of - Nothing -> [] - Just action -> [(emptyParamMap, action)] - xs -> - findRoute xs (rt_children globalTree) - where - findRoute :: [T.Text] -> V.Vector (RoutingTree a) -> [(ParamMap, a)] - findRoute fullPath trees = - let foundPaths = V.foldl' (matchTree fullPath emptyParamMap) V.empty trees - in V.toList foundPaths - where - matchTree :: [T.Text] -> ParamMap -> V.Vector (ParamMap, a) -> RoutingTree a -> V.Vector (ParamMap, a) - matchTree [] _ vec _ = vec - matchTree (textNode : xs) paramMap vec rt = - case matchNode textNode (rd_node $ rt_node rt) of - (False, _) -> - vec - (True, mCapture) -> - let paramMap' = - case mCapture of - Nothing -> paramMap - Just (var, value) -> - HM.insert var value paramMap - nodeData = rd_data $ rt_node rt - nodeChildren = rt_children rt - in case xs of - [] | isJust nodeData -> - V.snoc vec (paramMap', fromJust nodeData) - | otherwise -> - vec - _ -> - let foundPaths = V.foldl' (matchTree xs paramMap') V.empty nodeChildren - in V.concat [foundPaths, vec] matchNode :: T.Text -> RouteNode -> (Bool, Maybe (CaptureVar, T.Text)) matchNode _ RouteNodeRoot = (False, Nothing)