diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2014 Alexander Thiemann + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/reroute.cabal b/reroute.cabal new file mode 100644 --- /dev/null +++ b/reroute.cabal @@ -0,0 +1,53 @@ +name: reroute +version: 0.1.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 +license: MIT +license-file: LICENSE +author: Alexander Thiemann , Tim Baumann +maintainer: mail@agrafix.net +copyright: (c) 2014 Alexander Thiemann , Tim Baumann +category: Web +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: Web.Routing.AbstractRouter, Web.Routing.SafeRouting, Web.Routing.TextRouting + build-depends: base >=4.6 && <4.8, + transformers >=0.3 && <0.5, + text >= 0.11.3.1 && <1.3, + 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 + hs-source-dirs: src + default-language: Haskell2010 + + +test-suite reroutetest + type: exitcode-stdio-1.0 + hs-source-dirs: src + main-is: Web/Routing/Specs/Main.hs + other-modules: Web.Routing.Specs.SafeRoutingSpec, Web.Routing.Specs.TextRoutingSpec + 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 + default-language: Haskell2010 + ghc-options: -Wall -fno-warn-orphans + +source-repository head + type: git + location: git://github.com/agrafix/reroute.git diff --git a/src/Web/Routing/AbstractRouter.hs b/src/Web/Routing/AbstractRouter.hs new file mode 100644 --- /dev/null +++ b/src/Web/Routing/AbstractRouter.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +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 + +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 + 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) + +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) + } + +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 = + 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) + } + +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 + +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 route + initSt = + RegistryState + { rs_registry = HM.empty + } diff --git a/src/Web/Routing/SafeRouting.hs b/src/Web/Routing/SafeRouting.hs new file mode 100644 --- /dev/null +++ b/src/Web/Routing/SafeRouting.hs @@ -0,0 +1,165 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +module Web.Routing.SafeRouting where + +import Web.Routing.AbstractRouter + +import Data.HList +import Data.Maybe +import Data.Monoid +import Data.String +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)) + +newtype HListElim' x ts = HListElim' { flipHListElim :: HListElim 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 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) = + SafeRouterReg $ + insertPathMap (RouteHandle path (flipHListElim 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') + +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' + + +emptyPolyMap :: PolyMap x +emptyPolyMap = PMNil + +data PathMap x = PathMap [x] (HM.HashMap T.Text (PathMap x)) (PolyMap x) + +emptyPathMap :: PathMap x +emptyPathMap = PathMap mempty mempty emptyPolyMap + +insertPathMap' :: Path ts -> (HList ts -> x) -> PathMap x -> PathMap x +insertPathMap' path action (PathMap as m pm) = + 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) + +insertPathMap :: RouteHandle m a -> PathMap (m a) -> PathMap (m a) +insertPathMap (RouteHandle path action) = insertPathMap' path (hListUncurry 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 + 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 = StaticCons (T.pack s) Empty + +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 (HAppendList 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 p h = + T.intercalate "/" $ renderRoute' p h + +renderRoute' :: Path as -> HList as -> [T.Text] +renderRoute' Empty _ = [] +renderRoute' (StaticCons pathPiece pathXs) paramXs = + ( pathPiece : renderRoute' pathXs paramXs ) +renderRoute' (VarCons pathXs) (HCons val paramXs) = + ( toPathPiece val : renderRoute' pathXs paramXs) +renderRoute' _ _ = + error "This will never happen." + +parse :: Path as -> [T.Text] -> Maybe (HList as) +parse Empty [] = Just HNil +parse _ [] = Nothing +parse path (pathComp : xs) = + case path of + Empty -> Nothing + StaticCons pathPiece pathXs -> + if pathPiece == pathComp + then parse pathXs xs + else Nothing + VarCons pathXs -> + case fromPathPiece pathComp of + Nothing -> Nothing + Just val -> + let finish = parse pathXs xs + in fmap (\parsedXs -> HCons val parsedXs) finish diff --git a/src/Web/Routing/Specs/Main.hs b/src/Web/Routing/Specs/Main.hs new file mode 100644 --- /dev/null +++ b/src/Web/Routing/Specs/Main.hs @@ -0,0 +1,10 @@ +import qualified Web.Routing.Specs.TextRoutingSpec +import qualified Web.Routing.Specs.SafeRoutingSpec + +import Test.Hspec + +main :: IO () +main = + hspec $ + do Web.Routing.Specs.TextRoutingSpec.spec + Web.Routing.Specs.SafeRoutingSpec.spec diff --git a/src/Web/Routing/Specs/SafeRoutingSpec.hs b/src/Web/Routing/Specs/SafeRoutingSpec.hs new file mode 100644 --- /dev/null +++ b/src/Web/Routing/Specs/SafeRoutingSpec.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} +#if MIN_VERSION_base(4,7,0) +{-# LANGUAGE AllowAmbiguousTypes #-} +#endif +module Web.Routing.Specs.SafeRoutingSpec where + +import Test.Hspec + +import Control.Monad.Identity +import Web.Routing.SafeRouting +import Web.Routing.AbstractRouter +import qualified Data.Text as T + +data ReturnVar + = IntVar Int + | StrVar T.Text + | BoolVar Bool + | 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) + + +spec :: Spec +spec = + describe "SafeRouting Spec" $ + do it "shoud match known routes" $ + do checkRoute "" [StrVar "root"] + checkRoute "/bar" [StrVar "bar"] + it "shoudn't match unknown routes" $ + do checkRoute "/random" [] + checkRoute "/baz" [] + it "should capture variables in routes" $ + do checkRoute "/bar/23/baz" [IntVar 23] + checkRoute "/bar/23/baz/100" [ListVar [IntVar 23, IntVar 100]] + checkRoute "/bar/23/100" [ListVar [IntVar 23, IntVar 100]] + checkRoute "/entry/344/2014-20-14T12:23" [ListVar [IntVar 344, StrVar "2014-20-14T12:23"]] + checkRoute "/entry/bytags/344/2014-20-14T12:23" [ListVar [IntVar 344, StrVar "2014-20-14T12:23"]] + checkRoute "/entry/2/rel/3" [ListVar [IntVar 2, IntVar 3]] + it "should handle multiple possible matches correctly" $ + do checkRoute "/bar/5" [IntVar 5, StrVar "5"] + checkRoute "/bar/bingo" [StrVar "bar/bingo", StrVar "bingo"] + checkRoute "/entry/1/audit" [IntVar 1,ListVar [IntVar 1,StrVar "audit"]] + where + checkRoute :: T.Text -> [ReturnVar] -> Expectation + checkRoute r x = + let matches = handleFun (filter (not . T.null) $ T.splitOn "/" r) + in (map (runIdentity . snd) matches) `shouldBe` x + + handleFun :: [T.Text] -> [(ParamMap, Identity ReturnVar)] + handleFun = handleFun' True + (_, handleFun', _) = + runIdentity (runRegistry SafeRouter handleDefs) + + handleDefs = + do defR root $ return (StrVar "root") + defR "bar" $ return (StrVar "bar") + defR ("bar" var) (return . IntVar) + defR ("bar" var "baz") (return . IntVar) + defR ("bar" var "baz" var) $ \i i2 -> + return (ListVar [IntVar i, IntVar i2]) + defR ("bar" var var) $ \i i2 -> + return (ListVar [IntVar i, IntVar i2]) + defR ("entry" var var) $ \i st -> + return (ListVar [IntVar i, StrVar st]) + defR ("entry" "bytags" var var) $ \i st -> + return (ListVar [IntVar i, StrVar st]) + defR ("entry" var "rel" var) $ \i i2 -> + return (ListVar [IntVar i, IntVar i2]) + defR ("bar" "bingo") $ return (StrVar "bar/bingo") + defR ("bar" var) $ (return . StrVar . T.pack) + defR ("entry" var "audit") (return . IntVar) diff --git a/src/Web/Routing/Specs/TextRoutingSpec.hs b/src/Web/Routing/Specs/TextRoutingSpec.hs new file mode 100644 --- /dev/null +++ b/src/Web/Routing/Specs/TextRoutingSpec.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE OverloadedStrings #-} +module Web.Routing.Specs.TextRoutingSpec (spec) where + +import Test.Hspec + +import Web.Routing.TextRouting +import qualified Web.Routing.AbstractRouter as R +import qualified Data.Vector as V +import qualified Data.HashMap.Strict as HM + +spec :: Spec +spec = + do matchNodeDesc + matchRouteDesc + parseRouteNodeDesc + addToRoutingTreeDesc + +matchNodeDesc :: Spec +matchNodeDesc = + describe "matchNode" $ + do it "shouldn't match to root node" $ + matchNode "foo" RouteNodeRoot `shouldBe` (False, Nothing) + it "should capture basic variables" $ + matchNode "123" (RouteNodeCapture (R.CaptureVar "x")) `shouldBe` (True, Just (R.CaptureVar "x", "123")) + it "should work with regex" $ + matchNode "123" (RouteNodeRegex (R.CaptureVar "x") (buildRegex "^[0-9]+$")) `shouldBe` (True, Just (R.CaptureVar "x", "123")) + +matchRouteDesc :: Spec +matchRouteDesc = + describe "matchRoute" $ + do it "shouldn't match unknown routes" $ + do matchRoute "random" routingTree `shouldBe` noMatches + matchRoute "/baz" routingTree `shouldBe` noMatches + it "should match known routes" $ + do matchRoute "/" routingTree `shouldBe` oneMatch emptyParamMap [1] + matchRoute "/bar" routingTree `shouldBe` oneMatch emptyParamMap [2] + it "should capture variables in routes" $ + do matchRoute "/bar/5" routingTree `shouldBe` oneMatch (vMap [("baz", "5")]) [3] + matchRoute "/bar/23/baz" routingTree `shouldBe` oneMatch (vMap [("baz", "23")]) [4] + matchRoute "/bar/23/baz/100" routingTree `shouldBe` oneMatch (vMap [("baz", "23"), ("bim", "100")]) [4] + matchRoute "/ba/23/100" routingTree `shouldBe` oneMatch (vMap [("baz", "23"), ("bim", "100")]) [4] + matchRoute "/entry/344/2014-20-14T12:23" routingTree `shouldBe` oneMatch (vMap [("cid", "344"), ("since", "2014-20-14T12:23")]) [6] + matchRoute "/entry/bytags/344/2014-20-14T12:23" routingTree `shouldBe` oneMatch (vMap [("cid", "344"), ("since", "2014-20-14T12:23")]) [7] + matchRoute "/entry/2/rel/3" routingTree `shouldBe` oneMatch (vMap [("eid", "2"), ("cid", "3")]) [9] + it "should handle multiple possibile matches correctly" $ + do matchRoute "/bar/bingo" routingTree `shouldBe` multiMatch + matchRoute "/entry/1/audit" routingTree `shouldBe` multiMatch' + where + vMap kv = + HM.fromList $ map (\(k, v) -> (R.CaptureVar k, v)) kv + multiMatch = + ((oneMatch emptyParamMap [5]) + ++ oneMatch (vMap [("baz", "bingo")]) [3]) + multiMatch' = + ((oneMatch (vMap [("since", "audit"), ("cid", "1")]) [6]) + ++ (oneMatch (vMap [("eid", "1")]) [8])) + 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]$") + +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 new file mode 100644 --- /dev/null +++ b/src/Web/Routing/TextRouting.hs @@ -0,0 +1,216 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeFamilies #-} +module Web.Routing.TextRouting where + +import Web.Routing.AbstractRouter + +import Data.Maybe +import Data.String +import qualified Data.HashMap.Strict as HM +import qualified Data.Text as T +import qualified Data.Vector as V +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)) + 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) = + TextRouterRegistry $ + addToRoutingTree p a tree + matchRoute (TextRouterRegistry tree) path = + matchRoute' path tree + +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 + +data RouteNode + = RouteNodeRegex !CaptureVar !RegexWrapper + | RouteNodeCapture !CaptureVar + | RouteNodeText !T.Text + | RouteNodeRoot + deriving (Show, Eq) + +data RouteData a + = RouteData + { rd_node :: !RouteNode + , rd_data :: Maybe a + } + deriving (Show, Eq) + +data RoutingTree a + = RoutingTree + { rt_node :: !(RouteData a) + , rt_children :: !(V.Vector (RoutingTree a)) + } + deriving (Show, Eq) + +buildRegex :: T.Text -> RegexWrapper +buildRegex t = + RegexWrapper (Regex.mkRegex $ T.unpack t) t + +emptyRoutingTree :: RoutingTree a +emptyRoutingTree = + RoutingTree (RouteData RouteNodeRoot Nothing) V.empty + +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 + +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 + +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 + +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) +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))