nested-routes 6.0.0.1 → 6.1.0
raw patch · 3 files changed
+49/−35 lines, 3 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- nested-routes.cabal +2/−2
- src/Web/Routes/Nested.hs +28/−20
- src/Web/Routes/Nested/Types/UrlChunks.hs +19/−13
nested-routes.cabal view
@@ -1,5 +1,5 @@ Name: nested-routes-Version: 6.0.0.1+Version: 6.1.0 Author: Athan Clark <athan.clark@gmail.com> Maintainer: Athan Clark <athan.clark@gmail.com> License: BSD3@@ -62,7 +62,7 @@ Test-Suite test- Type: exitcode-stdio-1.0+ Type: exitcode-stdio-1.0 Default-Language: Haskell2010 HS-Source-Dirs: src , test
src/Web/Routes/Nested.hs view
@@ -112,6 +112,7 @@ import qualified Data.Trie.Class as TC import Data.Trie.Map (MapStep (..)) import qualified Data.Map as Map+import Data.List (stripPrefix) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE import qualified Data.Text as T@@ -365,13 +366,13 @@ -> MiddlewareT m extractContent hs app req respond = do (trie,_,_,_) <- execHandlerT hs- case lookupWithLRPT trimFileExt (pathInfo req) trie of+ case matchWithLRPT trimFileExt (pathInfo req) trie of Nothing -> fromMaybe (app req respond) $ do guard $ not . null $ pathInfo req guard $ trimFileExt (last $ pathInfo req) == "index" mid <- TC.lookup (init $ pathInfo req) trie- Just $ mid app req respond- Just mid -> mid app req respond+ Just $ mid app (adjustPathInfo (init $ pathInfo req) req) respond+ Just (prefix,mid) -> mid app (adjustPathInfo prefix req) respond -- | Find the security tokens / authorization roles affiliated with@@ -401,9 +402,10 @@ (f,me) <- authorize req ss fromMaybe (app req (respond . f)) $ do e <- me- (_,mid,_) <- PT.matchRPT (pathInfo req) trie- return $ mid e app req (respond . f)+ (prefix,mid,_) <- PT.matchRPT (pathInfo req) trie+ return $ mid e app (adjustPathInfo prefix req) (respond . f) + -- | Extracts only the @notFound@ responses into a @MiddlewareT@. extractNotFound :: ( Functor m , Monad m@@ -424,12 +426,8 @@ extractNearestVia extr hs app req respond = do trie <- extr hs maybe (app req respond)- (\mid -> mid app req respond)- $ getResultsFromMatch <$> PT.matchRPT (pathInfo req) trie---getResultsFromMatch :: ([s],a,[s]) -> a-getResultsFromMatch (_,x,_) = x+ (\(prefix, mid,_) -> mid app (adjustPathInfo prefix req) respond)+ $ PT.matchRPT (pathInfo req) trie @@ -460,28 +458,38 @@ -- | A quirky function for processing the last element of a lookup path, only -- on /literal/ matches.-lookupWithLPT :: Ord s => (s -> s) -> NonEmpty s -> PredTrie s a -> Maybe a-lookupWithLPT f (t:|ts) (PredTrie (MapStep ls) (PredSteps ps))+matchWithLPT :: Ord s => (s -> s) -> NonEmpty s -> PredTrie s a -> Maybe ([s], a)+matchWithLPT f (t:|ts) (PredTrie (MapStep 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 (mx,mxs) <- Map.lookup t' xs if null ts- then mx- else lookupWithLPT f (NE.fromList ts) =<< mxs+ then ([t],) <$> mx+ else (\(ts',x) -> (t:ts',x)) <$> (matchWithLPT f (NE.fromList ts) =<< mxs) +-- TODO: Need `match` for Map? idk actually, `t` should be enough for this step.+ goPred (PredStep _ predicate mx xs) = do d <- predicate t if null ts- then mx <$~> d- else lookupWithLPT f (NE.fromList ts) xs <$~> d+ then ([t],) <$> (mx <$~> d)+ else (\(ts',x) -> (t:ts',x d)) <$> (matchWithLPT f (NE.fromList ts) xs) -lookupWithLRPT :: Ord s => (s -> s) -> [s] -> RootedPredTrie s a -> Maybe a-lookupWithLRPT _ [] (RootedPredTrie mx _) = mx-lookupWithLRPT f ts (RootedPredTrie _ xs) = lookupWithLPT f (NE.fromList ts) xs+matchWithLRPT :: Ord 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 + tell' :: (Monoid w, S.MonadState w m) => w -> m () tell' x = do xs <- S.get S.put $ xs <> x+++adjustPathInfo :: [T.Text] -> Request -> Request+adjustPathInfo matched req' =+ req' { pathInfo = fromMaybe (error "non-prefix on match") $+ stripPrefix matched (pathInfo req')+ }
src/Web/Routes/Nested/Types/UrlChunks.hs view
@@ -29,16 +29,7 @@ import qualified Data.Text as T --- | Constrained to AttoParsec, Regex-Compat and T.Text-data EitherUrlChunk (x :: Maybe *) where- (:=) :: T.Text -> EitherUrlChunk 'Nothing- (:~) :: (T.Text, T.Text -> Maybe r) -> EitherUrlChunk ('Just r) --- | Use raw strings instead of prepending @l@-instance x ~ 'Nothing => IsString (EitherUrlChunk x) where- fromString = literal_ . T.pack-- o_, origin_ :: UrlChunks '[] o_ = origin_ @@ -70,17 +61,32 @@ pred_ :: (T.Text, T.Text -> Maybe r) -> EitherUrlChunk ('Just r) pred_ = (:~) --- | Prefix a routable path by more predicative lookup data.-(</>) :: EitherUrlChunk mx -> UrlChunks xs -> UrlChunks (mx ': xs)-(</>) = Cons -infixr 9 </>+-- | Constrained to AttoParsec, Regex-Compat and T.Text+data EitherUrlChunk (x :: Maybe *) where+ (:=) :: T.Text -> EitherUrlChunk 'Nothing+ (:~) :: (T.Text, T.Text -> Maybe r) -> EitherUrlChunk ('Just r) +-- | Use raw strings instead of prepending @l@+instance x ~ 'Nothing => IsString (EitherUrlChunk x) where+ fromString = literal_ . T.pack++ -- | Container when defining route paths data UrlChunks (xs :: [Maybe *]) where Cons :: EitherUrlChunk mx -> UrlChunks xs -> UrlChunks (mx ': xs) -- stack is left-to-right Root :: UrlChunks '[] +++-- | Prefix a routable path by more predicative lookup data.+(</>) :: EitherUrlChunk mx -> UrlChunks xs -> UrlChunks (mx ': xs)+(</>) = Cons++infixr 9 </>+++-- Utils eitherToMaybe :: Either String r -> Maybe r eitherToMaybe (Right r') = Just r'