reroute 0.4.1.0 → 0.5.0.0

raw patch · 5 files changed

+88/−51 lines, 5 filesdep ~basePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• reroute.cabal +1/−1
• src/Data/PolyMap.hs +11/−4
• src/Web/Routing/Router.hs +44/−31
• src/Web/Routing/SafeRouting.hs +9/−4
• test/Web/Routing/SafeRoutingSpec.hs +23/−11

@@ -1,5 +1,5 @@ name:                reroute-version:             0.4.1.0+version:             0.5.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/Spock

@@ -4,7 +4,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE GADTs #-}- module Data.PolyMap   ( PolyMap, empty, rnfHelper   , lookup, lookupApply, lookupApplyAll, lookupConcat@@ -13,10 +12,15 @@   , zipWith', zipWith, zip, ap   ) where -import Prelude hiding (lookup, zipWith, zip) import Data.Typeable-#if MIN_VERSION_base(4,8,0)+import Prelude hiding (lookup, zipWith, zip)+#if MIN_VERSION_base(4,11,0) import Control.Applicative (Alternative ((<|>)), liftA2)+#elif MIN_VERSION_base(4,9,0)+import Control.Applicative (Alternative ((<|>)), liftA2)+import Data.Semigroup+#elif MIN_VERSION_base(4,8,0)+import Control.Applicative (Alternative ((<|>)), liftA2) #else import Control.Applicative (Applicative (..), Alternative ((<|>)), liftA2) import Data.Monoid (Monoid (..))@@ -31,9 +35,12 @@   fmap _ PMNil = PMNil   fmap f (PMCons v pm) = PMCons (fmap ((.) f) v) (fmap f pm) +instance Alternative f => Semigroup (PolyMap c f a) where+  (<>) = union+ instance Alternative f => Monoid (PolyMap c f a) where   mempty = empty-  mappend = union+  mappend = (<>)  empty :: PolyMap c f a empty = PMNil

@@ -31,13 +31,15 @@  data RegistryState n b reqTypes    = RegistryState-   { rs_registry :: HM.HashMap reqTypes (Registry n b)+   { rs_registry :: !(HM.HashMap reqTypes (Registry n b))+   , rs_anyMethod :: !(Registry n b)    } -hookAny :: (Monad m, Eq reqTypes, Hashable reqTypes)-        => reqTypes-        -> ([T.Text] -> n b)-        -> RegistryT n b middleware reqTypes m ()+hookAny ::+    (Monad m, Eq reqTypes, Hashable reqTypes)+    => reqTypes+    -> ([T.Text] -> n b)+    -> RegistryT n b middleware reqTypes m () hookAny reqType action =     modify $ \rs ->         rs@@ -46,11 +48,23 @@                 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 ()+hookAnyMethod ::+    (Monad m)+    => ([T.Text] -> n b)+    -> RegistryT n b middleware reqTypes m ()+hookAnyMethod action =+    modify $+    \rs ->+        rs+        { rs_anyMethod = fallbackRoute action (rs_anyMethod 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 ->@@ -60,26 +74,23 @@                     in HM.insert reqType reg' (rs_registry rs)               } +hookRouteAnyMethod ::+    (Monad m)+    => PathInternal as+    -> HVectElim' (n b) as+    -> RegistryT n b middleware reqTypes m ()+hookRouteAnyMethod path action =+    do basePath <- ask+       modify $ \rs ->+           rs+           { rs_anyMethod = defRoute (basePath </!> path) action (rs_anyMethod 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)@@ -99,14 +110,16 @@             -> 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)+       return (val, handleF (rs_anyMethod st) (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)+      handleF anyReg hm ty route =+          let froute = filter (not . T.null) route+          in case HM.lookup ty hm of+               Nothing -> matchRoute anyReg froute+               Just registry ->+                   (matchRoute registry froute ++ matchRoute anyReg froute)       initSt =           RegistryState           { rs_registry = HM.empty+          , rs_anyMethod = emptyRegistry           }

@@ -6,7 +6,6 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}- module Web.Routing.SafeRouting where  import Data.HVect hiding (null, length)@@ -14,7 +13,10 @@ import qualified Data.PolyMap as PM  import Data.Maybe-#if MIN_VERSION_base(4,8,0)+#if MIN_VERSION_base(4,11,0)+#elif MIN_VERSION_base(4,9,0)+import Data.Semigroup+#elif MIN_VERSION_base(4,8,0) import Data.Monoid ((<>)) #else import Control.Applicative ((<$>))@@ -80,10 +82,13 @@ emptyPathMap :: PathMap x emptyPathMap = PathMap mempty mempty mempty PM.empty mempty +instance Semigroup (PathMap x) where+  (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)+ instance Monoid (PathMap x) where   mempty = emptyPathMap-  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)+  mappend = (<>)  updatePathMap   :: (forall y. (ctx -> y) -> PathMap y -> PathMap y)

@@ -4,15 +4,16 @@ {-# LANGUAGE OverloadedStrings #-} module Web.Routing.SafeRoutingSpec where -import Test.Hspec-import Data.HVect hiding (singleton)+import Web.Routing.Combinators+import Web.Routing.Router+import Web.Routing.SafeRouting  import Control.Monad.Identity import Control.Monad.RWS.Strict+import Data.HVect hiding (singleton)+import Data.List import Data.Maybe-import Web.Routing.Combinators-import Web.Routing.Router-import Web.Routing.SafeRouting+import Test.Hspec import qualified Data.HashMap.Strict as HM import qualified Data.Text as T @@ -21,11 +22,14 @@    | StrVar T.Text    | BoolVar Bool    | ListVar [ReturnVar]-   deriving (Show, Eq, Read)+   deriving (Show, Eq, Read, Ord)  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) +defRAny :: (Monad m, m ReturnVar ~ x) => Path ts ps -> HVectElim ts x -> RegistryT m ReturnVar middleware Bool m ()+defRAny path action = hookRouteAnyMethod (toInternalPath path) (HVectElim' action)+ -- TODO: abstract this code, move into AbstractRouter defSubComponent ::     ( Monad m@@ -54,6 +58,9 @@           do checkRoute "" [StrVar "root"]              checkRoute "/" [StrVar "root"]              checkRoute "/bar" [StrVar "bar"]+       it "should match any routes" $+          do checkRoute' "/any" True [StrVar "any", StrVar "any"] -- two due to hookAny+             checkRoute' "/any" False [StrVar "any"]        it "should capture variables in routes" $           do checkRoute "/bar/23/baz" [IntVar 23]              checkRoute "/bar/23/baz/" [IntVar 23]@@ -78,17 +85,22 @@       pieces :: T.Text -> [T.Text]       pieces = filter (not . T.null) . T.splitOn "/" +      checkRoute' :: T.Text -> Bool -> [ReturnVar] -> Expectation+      checkRoute' r b x =+          let matches = handleFun b (pieces r)+          in sort (map runIdentity matches) `shouldBe` sort x+       checkRoute :: T.Text -> [ReturnVar] -> Expectation-      checkRoute r x =-          let matches = handleFun (pieces r)-          in (map runIdentity matches) `shouldBe` x+      checkRoute = flip checkRoute' True -      handleFun :: [T.Text] -> [Identity ReturnVar]-      handleFun = handleFun' True+      handleFun :: Bool -> [T.Text] -> [Identity ReturnVar]+      handleFun = handleFun'+       (_, handleFun', _) = runIdentity (runRegistry handleDefs)        handleDefs =           do defR root $ return (StrVar "root")+             defRAny "any" $ pure (StrVar "any")              defR "bar" $ return (StrVar "bar")              defR ("bar" </> var) (return . IntVar)              defR ("bar" </> var </> "baz") (return . IntVar)