nested-routes 7.2.1 → 7.2.2
raw patch · 4 files changed
+97/−127 lines, 4 filesdep +tastydep +tasty-hspec
Dependencies added: tasty, tasty-hspec
Files
- nested-routes.cabal +4/−6
- src/Web/Routes/Nested.hs +85/−95
- src/Web/Routes/Nested/Types.hs +0/−25
- test/Test.hs +8/−1
nested-routes.cabal view
@@ -1,5 +1,5 @@ Name: nested-routes-Version: 7.2.1+Version: 7.2.2 Author: Athan Clark <athan.clark@gmail.com> Maintainer: Athan Clark <athan.clark@gmail.com> License: BSD3@@ -62,16 +62,12 @@ Test-Suite test Type: exitcode-stdio-1.0 Default-Language: Haskell2010- HS-Source-Dirs: src- , test+ HS-Source-Dirs: test GHC-Options: -Wall -threaded Main-Is: Test.hs Other-Modules: Spec Web.Routes.NestedSpec Web.Routes.NestedSpec.Basic- Web.Routes.Nested- Web.Routes.Nested.Types- Web.Routes.Nested.Match Build-Depends: base , nested-routes , attoparsec@@ -98,6 +94,8 @@ , wai-middleware-verbs , hspec , hspec-wai+ , tasty+ , tasty-hspec Executable example
src/Web/Routes/Nested.hs view
@@ -10,6 +10,7 @@ , FlexibleContexts , OverloadedStrings , ScopedTypeVariables+ , NamedFieldPuns #-} {- |@@ -81,16 +82,15 @@ import Network.Wai.Middleware.ContentType hiding (responseStatus, responseHeaders, responseData) import Data.Foldable (foldlM)-import qualified Data.HashTable.ST.Basic as HT-import Data.PredSet.Mutable as HS-import Data.Trie.Pred.Mutable (HashTableTrie (..), RootedHashTableTrie (..), RawValue (..))-import qualified Data.Trie.Pred.Mutable as MPT-import Data.Trie.Pred.Mutable.Morph (toMutableRooted)-import Data.Trie.Pred.Base (RootedPredTrie (..))+import Data.Trie.Pred.Base (RootedPredTrie (..), PredTrie (..))+import Data.Trie.Pred.Base.Step (PredStep (..), PredSteps (..))+import qualified Data.Trie.Pred.Interface as Interface import Data.Trie.Pred.Interface.Types (Singleton (..), Extrude (..), CatMaybes)-import Data.List.NonEmpty (NonEmpty (..))+import Data.Trie.HashMap (HashMapTrie (..), HashMapStep (..), HashMapChildren (..))+import Data.List.NonEmpty (NonEmpty (..), fromList) import qualified Data.Text as T import Data.Hashable+import qualified Data.HashMap.Strict as HM import Data.Monoid import Data.Function.Poly import Data.Typeable@@ -227,7 +227,6 @@ -- > route routes . routeAuth routes route :: ( Monad m , MonadIO m- , Typeable m ) => RouterT (MiddlewareT m) sec m a -- ^ The Router -> MiddlewareT m route hs app req resp = do@@ -250,8 +249,6 @@ routeAuth :: ( Monad m , MonadIO m , MonadThrow m- , Typeable sec- , Typeable m ) => (Request -> [sec] -> m ()) -- ^ authorization method -> RouterT (MiddlewareT m) (SecurityToken sec) m a -- ^ The Router -> MiddlewareT m@@ -264,22 +261,19 @@ -- | Extracts only the normal 'match', 'matchGroup' and 'matchHere' routes. extractMatch :: ( Monad m , MonadIO m- , Typeable r ) => [T.Text] -- ^ The path to match against -> RouterT r sec m a -- ^ The Router -> m (Maybe r) extractMatch path !hs = do- tries <- execRouterT hs- liftIO $ stToIO $ do- trie <- trieContentMutable tries- mResult <- lookupWithLRPT trimFileExt path trie- case mResult of- Nothing ->- if not (null path)- && trimFileExt (last path) == "index"- then MPT.lookupR (init path) trie- else pure Nothing- Just r -> return (Just r)+ Tries{trieContent} <- execRouterT hs+ let mResult = lookupWithLRPT trimFileExt path trieContent+ case mResult of+ Nothing ->+ if not (null path)+ && trimFileExt (last path) == "index"+ then pure $ Interface.lookup (init path) trieContent+ else pure Nothing+ Just (_,r) -> pure (Just r) {-# INLINEABLE extractMatch #-} @@ -287,7 +281,6 @@ -- | Extracts only the 'matchAny' responses; something like the greatest-lower-bound. extractMatchAny :: ( Monad m , MonadIO m- , Typeable r ) => [T.Text] -- ^ The path to match against -> RouterT r sec m a -- ^ The Router -> m (Maybe r)@@ -301,14 +294,13 @@ -- a request for a set of routes. extractAuthSym :: ( Monad m , MonadIO m- , Typeable sec ) => [T.Text] -- ^ The path to match against -> RouterT x (SecurityToken sec) m a -- ^ The Router -> m [sec] extractAuthSym path hs = do- tries <- execRouterT hs+ Tries{trieSecurity} <- execRouterT hs liftIO . stToIO $ do- results <- MPT.matchesR path =<< trieSecurityMutable tries+ let results = Interface.matches path trieSecurity pure $! foldr go [] results where go (_,SecurityToken _ DontProtectHere,[]) ys = ys@@ -320,7 +312,6 @@ extractAuth :: ( Monad m , MonadIO m , MonadThrow m- , Typeable sec ) => (Request -> [sec] -> m ()) -- ^ authorization method -> Request -> RouterT x (SecurityToken sec) m a@@ -337,7 +328,6 @@ -- greatest-lower-bound. extractNearestVia :: ( MonadIO m , Monad m- , Typeable r ) => [T.Text] -- ^ The path to match against -> (RouterT r sec m a -> m (RootedPredTrie T.Text r)) -> RouterT r sec m a@@ -345,7 +335,7 @@ extractNearestVia path extr hs = do trie <- extr hs liftIO . stToIO $ do- mResult <- MPT.matchR path =<< toMutableRooted trie+ let mResult = Interface.match path trie pure (mid <$> mResult) where mid (_,r,_) = r@@ -365,58 +355,58 @@ -- | A quirky function for processing the last element of a lookup path, only -- on /literal/ matches.--- lookupWithLPT :: ( Hashable s--- , Eq s--- ) => (s -> s) -> NonEmpty s -> PredTrie s a -> Maybe ([s], a)--- lookupWithLPT f (t:|ts) (PredTrie (HashMapStep ls) (PredSteps ps))--- | null ts = getFirst $ First ((goLit $! f t) ls) <> foldMap (First . goPred) ps--- | otherwise = getFirst $ First (goLit t ls) <> foldMap (First . goPred) ps--- where--- goLit t' xs = do--- (HashMapChildren mx mxs) <- HM.lookup t' xs--- if null ts--- then ([t],) <$> mx--- else fmap (\(ts',x) -> (t:ts',x)) $! lookupWithLPT f (NE.fromList ts) =<< mxs------ goPred (PredStep _ predicate mx xs) = do--- d <- predicate t--- if null ts--- then ([t],) <$> (mx <$~> d)--- else fmap (\(ts',x) -> (t:ts',x d)) $! lookupWithLPT f (NE.fromList ts) xs+lookupWithLPT :: ( Hashable s+ , Eq s+ ) => (s -> s) -> NonEmpty s -> PredTrie s a -> Maybe ([s], a)+lookupWithLPT f (t:|ts) (PredTrie (HashMapStep ls) (PredSteps ps))+ | null ts = getFirst $ First ((goLit $! f t) ls) <> foldMap (First . goPred) ps+ | otherwise = getFirst $ First (goLit t ls) <> foldMap (First . goPred) ps+ where+ goLit t' xs = do+ (HashMapChildren mx mxs) <- HM.lookup t' xs+ if null ts+ then ([t],) <$> mx+ else fmap (\(ts',x) -> (t:ts',x)) $! lookupWithLPT f (fromList ts) =<< mxs -lookupWithLPT :: ( Eq k- , Hashable k- , Typeable s- , Typeable k- ) => PredSet s k- -> (k -> k)- -> NonEmpty k- -> HashTableTrie s k a- -> ST s (Maybe a)-lookupWithLPT predSet f (k:|ks) (HashTableTrie raw preds) = do- mx <- HT.lookup raw $ if null ks then f k else k- case mx of- Just (RawValue mx' children) ->- case ks of- [] -> pure mx'- (k':ks') -> lookupWithLPT predSet f (k':|ks') children- Nothing ->- let -- go :: Typeable t => Maybe t -> PredStep s k t -> ST s (Maybe t)- go solution@(Just _) _ = pure solution- go Nothing (MPT.PredStep predKey mHandler children) = do- mx' <- HS.lookup predKey k predSet- case mx' of- Nothing -> pure Nothing- Just x ->- case ks of- [] ->- pure $! ($ x) <$> mHandler- (k':ks') -> do- mf <- lookupWithLPT predSet f (k':|ks') children- pure $! ($ x) <$> mf- in foldlM go Nothing preds+ goPred (PredStep _ predicate mx xs) = do+ d <- predicate t+ if null ts+ then ([t],) <$> (($ d) <$> mx)+ else fmap (\(ts',x) -> (t:ts',x d)) $! lookupWithLPT f (fromList ts) xs -- lookupWithLPT :: ( Eq k+-- , Hashable k+-- , Typeable s+-- , Typeable k+-- ) => PredSet s k+-- -> (k -> k)+-- -> NonEmpty k+-- -> PredTrie k a+-- -> ST s (Maybe a)+-- lookupWithLPT predSet f (k:|ks) (HashTableTrie raw preds) = do+-- mx <- HT.lookup raw $ if null ks then f k else k+-- case mx of+-- Just (RawValue mx' children) ->+-- case ks of+-- [] -> pure mx'+-- (k':ks') -> lookupWithLPT predSet f (k':|ks') children+-- Nothing ->+-- let -- go :: Typeable t => Maybe t -> PredStep s k t -> ST s (Maybe t)+-- go solution@(Just _) _ = pure solution+-- go Nothing (MPT.PredStep predKey mHandler children) = do+-- mx' <- HS.lookup predKey k predSet+-- case mx' of+-- Nothing -> pure Nothing+-- Just x ->+-- case ks of+-- [] ->+-- pure $! ($ x) <$> mHandler+-- (k':ks') -> do+-- mf <- lookupWithLPT predSet f (k':|ks') children+-- pure $! ($ x) <$> mf+-- in foldlM go Nothing preds++-- lookupWithLPT :: ( Eq k -- , Hashable k -- , Typeable s -- , Typeable k@@ -472,11 +462,11 @@ {-# INLINEABLE lookupWithLPT #-} ---lookupWithLRPT :: ( Hashable s--- , Eq s--- ) => (s -> s) -> [s] -> RootedPredTrie s a -> Maybe ([s], a)---lookupWithLRPT _ [] (RootedPredTrie mx _) = ([],) <$> mx---lookupWithLRPT f ts (RootedPredTrie _ xs) = lookupWithLPT f (NE.fromList ts) xs+lookupWithLRPT :: ( Hashable s+ , Eq s+ ) => (s -> s) -> [s] -> RootedPredTrie s a -> Maybe ([s], a)+lookupWithLRPT _ [] (RootedPredTrie mx _) = ([],) <$> mx+lookupWithLRPT f ts (RootedPredTrie _ xs) = lookupWithLPT f (fromList ts) xs -- lookupWithLRPT :: ( Eq k -- , Hashable k@@ -495,18 +485,18 @@ -- First ((\(pre,x,suff) -> (NE.toList pre,x,suff)) <$> mFoundThere) -- <> First ((\x -> ([],x,k:ks)) <$> mx) -lookupWithLRPT :: ( Eq k- , Hashable k- , Typeable s- , Typeable k- , Typeable a- ) => (k -> k)- -> [k]- -> RootedHashTableTrie s k a- -> ST s (Maybe a)-lookupWithLRPT _ [] (RootedHashTableTrie mx _ _) = pure mx-lookupWithLRPT f (k:ks) (RootedHashTableTrie _ xs predSet) =- lookupWithLPT predSet f (k:|ks) xs+-- lookupWithLRPT :: ( Eq k+-- , Hashable k+-- , Typeable s+-- , Typeable k+-- , Typeable a+-- ) => (k -> k)+-- -> [k]+-- -> RootedHashTableTrie s k a+-- -> ST s (Maybe a)+-- lookupWithLRPT _ [] (RootedHashTableTrie mx _ _) = pure mx+-- lookupWithLRPT f (k:ks) (RootedHashTableTrie _ xs predSet) =+-- lookupWithLPT predSet f (k:|ks) xs
src/Web/Routes/Nested/Types.hs view
@@ -19,9 +19,6 @@ module Web.Routes.Nested.Types ( -- * Internal Structure Tries (..)- , trieContentMutable- , trieCatchAllMutable- , trieSecurityMutable , -- * Builder RouterT (..) , execRouterT@@ -35,18 +32,14 @@ import Network.Wai.Middleware.Verbs import Network.Wai.Middleware.ContentType import Network.Wai.Trans-import Data.Trie.Pred.Mutable-import Data.Trie.Pred.Mutable.Morph import Data.Trie.Pred.Base (RootedPredTrie (..)) import Data.Trie.Pred.Interface.Types (Extrude (..), CatMaybes) -import Data.Typeable import Data.Monoid import qualified Data.Text as T import Data.Function.Poly import Control.Monad.Trans import qualified Control.Monad.State as S-import Control.Monad.ST @@ -57,24 +50,6 @@ , trieSecurity :: !(RootedPredTrie T.Text s) } --trieContentMutable :: ( Typeable x- , Typeable s- ) => Tries x s'- -> ST s (RootedHashTableTrie s T.Text x)-trieContentMutable (Tries x _ _) = toMutableRooted x--trieCatchAllMutable :: ( Typeable x- , Typeable s- ) => Tries x s'- -> ST s (RootedHashTableTrie s T.Text x)-trieCatchAllMutable (Tries _ x _) = toMutableRooted x--trieSecurityMutable :: ( Typeable s'- , Typeable s- ) => Tries x s'- -> ST s (RootedHashTableTrie s T.Text s')-trieSecurityMutable (Tries _ _ x) = toMutableRooted x instance Monoid (Tries x s) where mempty = Tries mempty mempty mempty
test/Test.hs view
@@ -1,5 +1,12 @@+module Main where+ import Test.Hspec (hspec) import Spec (spec)+import Test.Tasty+import Test.Tasty.Hspec + main :: IO ()-main = hspec spec+main = do+ r <- testSpec "basic" spec+ defaultMain r