nested-routes 7.0.0 → 7.1.0
raw patch · 3 files changed
+212/−37 lines, 3 filesdep +hashtablesdep +pred-setdep ~pred-trie
Dependencies added: hashtables, pred-set
Dependency ranges changed: pred-trie
Files
- nested-routes.cabal +6/−2
- src/Web/Routes/Nested.hs +183/−35
- src/Web/Routes/Nested/Types.hs +23/−0
nested-routes.cabal view
@@ -1,5 +1,5 @@ Name: nested-routes-Version: 7.0.0+Version: 7.1.0 Author: Athan Clark <athan.clark@gmail.com> Maintainer: Athan Clark <athan.clark@gmail.com> License: BSD3@@ -43,9 +43,11 @@ , errors , exceptions , hashable+ , hashtables , mtl , poly-arity >= 0.0.7- , pred-trie >= 0.5.0+ , pred-set >= 0.0.1+ , pred-trie >= 0.5.1 , regex-compat , semigroups , text@@ -114,9 +116,11 @@ , errors , exceptions , hashable+ , hashtables , http-types , mtl , poly-arity+ , pred-set , pred-trie , regex-compat , semigroups
src/Web/Routes/Nested.hs view
@@ -77,6 +77,12 @@ import Network.Wai.Middleware.Verbs 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 qualified Data.Trie.Pred.Base as PT -- only using lookups import Data.Trie.Pred.Base (RootedPredTrie (..), PredTrie (..)) import Data.Trie.Pred.Base.Step (PredStep (..), PredSteps (..))@@ -91,11 +97,13 @@ import Data.Monoid import Data.Functor.Syntax import Data.Function.Poly+import Data.Typeable import Control.Monad import qualified Control.Monad.State as S import Control.Monad.Catch import Control.Monad.Trans+import Control.Monad.ST -- | Embed a 'Network.Wai.Trans.MiddlewareT' into a set of routes via a matching string. You should@@ -206,6 +214,8 @@ -- * Routing --------------------------------------- route :: ( Monad m+ , MonadIO m+ , Typeable m ) => HandlerT (MiddlewareT m) sec m a -> MiddlewareT m route hs app req resp = do@@ -221,7 +231,10 @@ Just mid -> mid app req resp routeAuth :: ( Monad m+ , MonadIO m , MonadThrow m+ , Typeable sec+ , Typeable m ) => (Request -> [sec] -> m ()) -> HandlerT (MiddlewareT m) (SecurityToken sec) m a -> MiddlewareT m@@ -233,23 +246,31 @@ -- | Extracts only the normal 'match' and 'matchHere' extractMatch :: ( Monad m+ , MonadIO m+ , Typeable r ) => [T.Text] -> HandlerT r sec m a -> m (Maybe r) extractMatch path !hs = do- trie <- trieContent <$> execHandlerT hs- case matchWithLRPT trimFileExt path trie of- Nothing -> return $ do- guard $ not (null path)- guard $ trimFileExt (last path) == "index"- TC.lookup (init path) trie- Just (_,r) -> return (Just r)+ tries <- execHandlerT 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) {-# INLINEABLE extractMatch #-} -- | Extracts only the @notFound@ responses extractMatchAny :: ( Monad m+ , MonadIO m+ , Typeable r ) => [T.Text] -> HandlerT r sec m a -> m (Maybe r)@@ -262,12 +283,16 @@ -- | Find the security tokens / authorization roles affiliated with -- a request for a set of routes. extractAuthSym :: ( Monad m+ , MonadIO m+ , Typeable sec ) => [T.Text] -> HandlerT x (SecurityToken sec) m a -> m [sec] extractAuthSym path hs = do- trie <- trieSecurity <$> execHandlerT hs- return $! foldr go [] $ PT.matchesRPT path trie+ tries <- execHandlerT hs+ liftIO . stToIO $ do+ results <- MPT.matchesR path =<< trieSecurityMutable tries+ pure $! foldr go [] results where go (_,SecurityToken _ DontProtectHere,[]) ys = ys go (_,SecurityToken x _ ,_ ) ys = x:ys@@ -276,7 +301,9 @@ -- | Extracts only the security handling logic, and turns it into a guard extractAuth :: ( Monad m+ , MonadIO m , MonadThrow m+ , Typeable sec ) => (Request -> [sec] -> m ()) -- authorization method -> Request -> HandlerT x (SecurityToken sec) m a@@ -290,14 +317,18 @@ -- | Given a way to draw out a special-purpose trie from our route set, route -- to the responses based on a /furthest-reached/ method.-extractNearestVia :: ( Monad m+extractNearestVia :: ( MonadIO m+ , Monad m+ , Typeable r ) => [T.Text] -> (HandlerT r sec m a -> m (RootedPredTrie T.Text r)) -> HandlerT r sec m a -> m (Maybe r) extractNearestVia path extr hs = do trie <- extr hs- pure (mid <$> PT.matchRPT path trie)+ liftIO . stToIO $ do+ mResult <- MPT.matchR path =<< toMutableRooted trie+ pure (mid <$> mResult) where mid (_,r,_) = r @@ -316,35 +347,152 @@ -- | A quirky function for processing the last element of a lookup path, only -- on /literal/ matches.-matchWithLPT :: ( Hashable s- , Eq s- ) => (s -> s) -> NonEmpty s -> PredTrie s a -> Maybe ([s], a)-matchWithLPT 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)) $! matchWithLPT f (NE.fromList ts) =<< mxs+-- 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 - goPred (PredStep _ predicate mx xs) = do- d <- predicate t- if null ts- then ([t],) <$> (mx <$~> d)- else fmap (\(ts',x) -> (t:ts',x d)) $! matchWithLPT f (NE.fromList ts) xs+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 -{-# INLINEABLE matchWithLPT #-}+-- lookupWithLPT :: ( Eq k+-- , Hashable k+-- , Typeable s+-- , Typeable k+-- ) => PredSet s k+-- -> (k -> k)+-- -> NonEmpty k+-- -> HashTableTrie s k a+-- -> ST s (Maybe (NonEmpty k, a, [k]))+-- lookupWithLPT predSet f (k:|ks) (HashTableTrie raw preds) = do+-- mLit <- goLit raw+-- case mLit of+-- Just _ -> pure mLit+-- Nothing ->+-- let go solution@(Just _) _ = pure solution+-- go Nothing pred = goPred pred+-- in foldlM go Nothing preds+-- where+-- goLit xs = do+-- mx' <- if null ks+-- then HT.lookup raw (f k)+-- else HT.lookup raw k+-- case mx' of+-- Nothing -> pure Nothing+-- Just (RawValue mx children) ->+-- let mFoundHere = (\x -> (k:|[], x, ks)) <$> mx+-- prependAncestry (pre,x,suff) = (k:|NE.toList pre,x,suff)+-- in case ks of+-- [] -> pure mFoundHere+-- (k':ks') -> do+-- mFoundThere <- MPT.match predSet (k':|ks') children+-- pure $! getFirst $+-- First (prependAncestry <$> mFoundThere)+-- <> First mFoundHere+-- +-- goPred (MPT.PredStep predKey mx children) = do+-- mr' <- HS.lookup predKey k predSet+-- case mr' of+-- Nothing -> pure Nothing+-- Just r ->+-- let mFoundHere = (\x -> (k:|[], x r, ks)) <$> mx+-- prependAncestryAndApply (pre,f,suff) =+-- (k:|NE.toList pre,f r,suff)+-- in case ks of+-- [] -> pure mFoundHere+-- (k':ks') -> do+-- mFoundThere <- MPT.match predSet (k':|ks') children+-- pure $! getFirst $+-- First (prependAncestryAndApply <$> mFoundThere)+-- <> First mFoundHere -matchWithLRPT :: ( Hashable s- , Eq s- ) => (s -> s) -> [s] -> RootedPredTrie s a -> Maybe ([s], a)-matchWithLRPT _ [] (RootedPredTrie mx _) = ([],) <$> mx-matchWithLRPT f ts (RootedPredTrie _ xs) = matchWithLPT f (NE.fromList ts) xs -{-# INLINEABLE matchWithLRPT #-}+{-# 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 :: ( Eq k+-- , Hashable k+-- , Typeable s+-- , Typeable k+-- , Typeable a+-- ) => (k -> k)+-- -> [k]+-- -> RootedHashTableTrie s k a+-- -> ST s (Maybe ([k],a,[k]))+-- lookupWithLRPT _ [] (RootedHashTableTrie mx _ _) =+-- pure $! (\x -> ([],x,[])) <$> mx+-- lookupWithLRPT f (k:ks) (RootedHashTableTrie mx xs predSet) = do+-- mFoundThere <- lookupWithLPT predSet f (k:|ks) xs+-- pure $! getFirst $+-- 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++++{-# INLINEABLE lookupWithLRPT #-} tell' :: (Monoid w, S.MonadState w m) => w -> m ()
src/Web/Routes/Nested/Types.hs view
@@ -12,22 +12,45 @@ 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 + -- | The internal data structure built during route declaration. data Tries x s = Tries { trieContent :: !(RootedPredTrie T.Text x) , trieCatchAll :: !(RootedPredTrie T.Text x) , 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