packages feed

reroute (empty) → 0.1.0.0

raw patch · 9 files changed

+746/−0 lines, 9 filesdep +HListdep +basedep +hashablesetup-changed

Dependencies added: HList, base, hashable, hspec2, mtl, path-pieces, regex-compat, text, transformers, unordered-containers, vector

Files

+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2014 Alexander Thiemann <mail@agrafix.net>++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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ reroute.cabal view
@@ -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 <mail@agrafix.net>, Tim Baumann <tim@timbaumann.info>+maintainer:          mail@agrafix.net+copyright:           (c) 2014 Alexander Thiemann <mail@agrafix.net>, Tim Baumann <tim@timbaumann.info>+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
+ src/Web/Routing/AbstractRouter.hs view
@@ -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+          }
+ src/Web/Routing/SafeRouting.hs view
@@ -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
+ src/Web/Routing/Specs/Main.hs view
@@ -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
+ src/Web/Routing/Specs/SafeRoutingSpec.hs view
@@ -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)
+ src/Web/Routing/Specs/TextRoutingSpec.hs view
@@ -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}]}]}
+ src/Web/Routing/TextRouting.hs view
@@ -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))