wai-route 0.2 → 0.3
raw patch · 5 files changed
+89/−33 lines, 5 filesdep ~wai
Dependency ranges changed: wai
Files
- sample/Main.hs +5/−5
- src/Network/Wai/Route.hs +4/−4
- src/Network/Wai/Route/Tree.hs +72/−13
- test/Test/Network/Wai/Route.hs +6/−9
- wai-route.cabal +2/−2
sample/Main.hs view
@@ -16,10 +16,10 @@ , ("/foo/:bar/:baz", bazHandler) ] where- fooHandler _ _ = return $ responseLBS status200 [] "foo!"- barHandler _ _ = return $ responseLBS status200 [] "bar!"- bazHandler p rq = do+ fooHandler _ _ k = k $ responseLBS status200 [] "foo!"+ barHandler _ _ k = k $ responseLBS status200 [] "bar!"+ bazHandler p rq k = do print $ "pathInfo: " ++ show (pathInfo rq) print $ "captured: " ++ show p- return $ responseLBS status200 []- $ maybe L.empty L.fromStrict (lookup "baz" p)+ k $ responseLBS status200 []+ $ maybe L.empty L.fromStrict (lookup "baz" p)
src/Network/Wai/Route.hs view
@@ -30,9 +30,9 @@ -> Request -> (Response -> m ResponseReceived) -> m ResponseReceived-route rs rq k = case lookup (fromList rs) path of- Just (f, c) -> f c rq k- Nothing -> k notFound+route rs rq k = case lookup (fromList rs) segs of+ Just e -> value e (captured $ captures e) rq k+ Nothing -> k notFound where- path = segments (rawPathInfo rq)+ segs = segments (rawPathInfo rq) notFound = responseLBS status404 [] L.empty
src/Network/Wai/Route/Tree.hs view
@@ -3,13 +3,29 @@ -- file, You can obtain one at http://mozilla.org/MPL/2.0/. module Network.Wai.Route.Tree- ( Tree+ ( -- * Routing Tree+ Tree , fromList , lookup+ , foldTree+ , mapTree+ , toList , segments++ -- ** Tree leaf payload+ , Payload+ , value+ , path+ , captures++ -- ** Captures+ , Captures+ , captured+ , captureParams+ , captureValues ) where -import Control.Applicative ((<|>))+import Control.Applicative import Data.ByteString (ByteString) import Data.List (foldl') import Data.HashMap.Strict (HashMap)@@ -25,41 +41,84 @@ data Tree a = Tree { subtree :: HashMap ByteString (Tree a) , capture :: Maybe (Tree a)- , payload :: Maybe (a, [ByteString])+ , payload :: Maybe (Payload a) } +data Payload a = Payload+ { value :: !a+ , path :: !ByteString+ , captures :: !Captures+ }++data Captures = Captures+ { params :: [ByteString]+ , values :: [ByteString]+ }+ instance Monoid (Tree a) where mempty = Tree mempty Nothing Nothing a `mappend` b = Tree (subtree a <> subtree b) (capture a <> capture b) (payload a <|> payload b) +captureParams :: Captures -> [ByteString]+captureParams = params++captureValues :: Captures -> [ByteString]+captureValues = values++captured :: Captures -> [(ByteString, ByteString)]+captured (Captures a b) = zip a b+ fromList :: [(ByteString, a)] -> Tree a fromList = foldl' addRoute mempty where- addRoute t (p,pl) = go t (segments p) []+ addRoute t p = go t (segments (fst p)) [] where- go n [] cs = n { payload = Just (pl, cs) }+ go n [] cs =+ n { payload = Just (Payload (snd p) (fst p) (Captures cs [])) }+ go n (c:ps) cs | B.head c == colon =- let b = fromMaybe mempty $ capture n- in n { capture = Just $! go b ps (B.tail c : cs) }+ let b = fromMaybe mempty $ capture n in+ n { capture = Just $! go b ps (B.tail c : cs) }+ go n (d:ps) cs = let d' = urlEncode False d b = fromMaybe mempty $ M.lookup d' (subtree n) in n { subtree = M.insert d' (go b ps cs) (subtree n) } -lookup :: Tree a -> [ByteString] -> Maybe (a, [(ByteString, ByteString)])+lookup :: Tree a -> [ByteString] -> Maybe (Payload a) lookup t p = go p [] t where- go [] cvs n = let f (pl, cs) = (pl, cs `zip` cvs)- in f `fmap` payload n- go (s:ss) cvs n = maybe (capture n >>= go ss (urlDecode False s : cvs))- (go ss cvs)- (M.lookup s $ subtree n)+ go [] cvs n =+ let f e = e { captures = Captures (params (captures e)) cvs } in+ f <$> payload n + go (s:ss) cvs n =+ maybe (capture n >>= go ss (urlDecode False s : cvs))+ (go ss cvs)+ (M.lookup s $ subtree n)++foldTree :: (Payload a -> b -> b) -> b -> Tree a -> b+foldTree f z (Tree sub cap pay) =+ let a = M.foldl' (foldTree f) z sub+ b = maybe a (foldTree f a) cap+ c = maybe b (flip f b) pay+ in c++mapTree :: (Payload a -> Payload b) -> Tree a -> Tree b+mapTree f t = foldTree apply mempty t+ where+ apply x tr = tr { payload = Just (f x) }++toList :: Tree a -> [Payload a]+toList = foldTree (:) []+ segments :: ByteString -> [ByteString] segments = filter (not . B.null) . B.split slash slash, colon :: Word8 slash = 0x2F colon = 0x3A+{-# INLINE slash #-}+{-# INLINE colon #-}
test/Test/Network/Wai/Route.hs view
@@ -15,7 +15,7 @@ import Data.Monoid ((<>)) import Network.HTTP.Types import Network.Wai-import Network.Wai.Internal (ResponseReceived (..)) +import Network.Wai.Internal (ResponseReceived (..)) import Network.Wai.Route import Test.Tasty import Test.Tasty.QuickCheck@@ -32,11 +32,11 @@ check routes = let h1 = route $ map (fmap unHandler) routes rsv = routes >>= C.split '/' . fst- res = const $ return ResponseReceived + res = const $ return ResponseReceived in conjoin . flip map routes $ \(r, TestHandler h2) -> forAll (genReq r rsv) $ \(params2, rq) ->- let result1 = h1 rq res -- routed - result2 = h2 [] rq res -- direct + let result1 = h1 rq res -- routed+ result2 = h2 [] rq res -- direct (hId1, params1) = execState result1 (-1, []) (hId2, _) = execState result2 (-1, []) in hId1 == hId2 && params1 == params2@@ -51,9 +51,9 @@ show _ = "<test-handler>" handler :: Int -> TestHandler-handler i = TestHandler $ \p _ k -> do +handler i = TestHandler $ \p _ k -> do put (i, p)- k $ responseLBS status200 [] L.empty + k $ responseLBS status200 [] L.empty genDir :: Gen ByteString genDir = C.pack <$> listOf1 arbitrary `suchThat` f@@ -98,6 +98,3 @@ segs = C.split '/' r toSeg (s, v) | C.head s == ':' = urlEncode False v | otherwise = urlEncode False s--instance Show Request where- show = show . rawPathInfo
wai-route.cabal view
@@ -1,5 +1,5 @@ name: wai-route-version: 0.2+version: 0.3 synopsis: Minimalistic, efficient routing for WAI description: .@@ -32,7 +32,7 @@ build-depends: base == 4.*- , wai == 3.0.*+ , wai >= 3.0.2 && < 3.1 , unordered-containers >= 0.2 , http-types >= 0.8 , bytestring >= 0.10