wai-routing 0.8 → 0.9
raw patch · 6 files changed
+140/−83 lines, 6 filesdep ~attoparsecdep ~waidep ~wai-predicates
Dependency ranges changed: attoparsec, wai, wai-predicates, wai-route
Files
- CHANGELOG.md +6/−0
- examples/eval-routing.hs +3/−1
- src/Network/Wai/Routing/Route.hs +71/−33
- test/Tests/Wai/Route.hs +43/−40
- test/Tests/Wai/Util.hs +8/−0
- wai-routing.cabal +9/−9
CHANGELOG.md view
@@ -1,3 +1,9 @@+0.9+-----------------------------------------------------------------------------+- Update to WAI 3.0.x and honour the new CPS definition of `Application`+ (cf. the documentation of `Network.Wai.Routing.Route.continue` for details+ regarding the differences between old and new style handler types).+ 0.8 ----------------------------------------------------------------------------- - Update to `wai-predicates 0.6` and change default error renderer.
examples/eval-routing.hs view
@@ -32,7 +32,9 @@ main = run 8080 $ logStdout (route (prepare start)) start :: Monad m => Routes a m ()-start = get "eval" eval (query "x" .&. query "y" .&. query "f")+start =+ get "eval" (continue eval) $+ query "x" .&. query "y" .&. query "f" eval :: Monad m => Int ::: Int ::: Op -> m Response eval (x ::: y ::: f) = respond status200 . fromString . show $
src/Network/Wai/Routing/Route.hs view
@@ -2,14 +2,18 @@ -- License, v. 2.0. If a copy of the MPL was not distributed with this -- file, You can obtain one at http://mozilla.org/MPL/2.0/. -{-# LANGUAGE GADTs #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-} module Network.Wai.Routing.Route ( Routes+ , App+ , Continue , Meta (..) , prepare , route+ , continue , addRoute , attach , examine@@ -37,7 +41,7 @@ import Data.Maybe (fromMaybe, mapMaybe, catMaybes) import Data.Monoid import Network.HTTP.Types-import Network.Wai (Request, Response, responseLBS, responseBuilder, rawPathInfo)+import Network.Wai import Network.Wai.Predicate import Network.Wai.Predicate.Request import Network.Wai.Routing.Request@@ -56,12 +60,21 @@ data Handler m = Handler { _delta :: !Double- , _handler :: m Response+ , _handler :: m ResponseReceived } data Pack m where- Pack :: Predicate RoutingReq Error a -> (a -> m Response) -> Pack m+ Pack :: Predicate RoutingReq Error a+ -> (a -> Continue m -> m ResponseReceived)+ -> Pack m +-- | The WAI 3.0 application continuation for arbitrary @m@ instead of @IO@.+type Continue m = Response -> m ResponseReceived++-- | Similar to a WAI 'Application' but for 'RoutingReq' and not specific+-- to @IO@.+type App m = RoutingReq -> Continue m -> m ResponseReceived+ -- | Function to turn an 'Error' value into a 'Lazy.ByteString'. -- Clients can provide their own renderer using 'renderer'. type Renderer = Error -> Maybe Lazy.ByteString@@ -123,11 +136,16 @@ -- | Add a route for some 'Method' and path (potentially with variable -- captures) and constrained by some 'Predicate'.+--+-- A route handler is like a WAI 'Application' but instead of 'Request'+-- the first parameter is the result-type of the associated 'Predicate'+-- evaluation. I.e. the handler is applied to the predicate's metadata+-- value iff the predicate is true. addRoute :: Monad m => Method- -> ByteString -- ^ path- -> (a -> m Response) -- ^ handler- -> Predicate RoutingReq Error a -- ^ 'Predicate'+ -> ByteString -- ^ path+ -> (a -> Continue m -> m ResponseReceived) -- ^ handler+ -> Predicate RoutingReq Error a -- ^ 'Predicate' -> Routes b m () addRoute m r x p = Routes . modify $ \s -> s { routes = Route m r Nothing (Pack p x) : routes s }@@ -135,9 +153,9 @@ -- | Specialisation of 'addRoute' for a specific HTTP 'Method'. get, head, post, put, delete, trace, options, connect, patch :: Monad m- => ByteString -- ^ path- -> (a -> m Response) -- ^ handler- -> Predicate RoutingReq Error a -- ^ 'Predicate'+ => ByteString -- ^ path+ -> (a -> Continue m -> m ResponseReceived) -- ^ handler+ -> Predicate RoutingReq Error a -- ^ 'Predicate' -> Routes b m () get = addRoute (renderStdMethod GET) head = addRoute (renderStdMethod HEAD)@@ -161,19 +179,39 @@ examine (Routes r) = let St rr _ = execState r zero in mapMaybe (\x -> Meta (_method x) (_path x) <$> _meta x) rr --- | A WAI 'Application' (generalised from 'IO' to 'Monad') which--- routes requests to handlers based on predicated route declarations.-route :: Monad m => [(ByteString, RoutingReq -> m Response)] -> Request -> m Response-route rm rq = do+-- | Routes requests to handlers based on predicated route declarations.+-- Note that @route (prepare ...)@ behaves like a WAI 'Application' generalised to+-- arbitrary monads.+route :: Monad m => [(ByteString, App m)] -> Request -> Continue m -> m ResponseReceived+route rm rq k = do let tr = Tree.fromList rm case Tree.lookup tr (Tree.segments $ rawPathInfo rq) of- Just (f, v) -> f (fromReq v (fromRequest rq))- Nothing -> return notFound+ Just (f, v) -> f (fromReq v (fromRequest rq)) k+ Nothing -> k notFound where notFound = responseLBS status404 [] "" +-- | Prior to WAI 3.0 applications returned a plain 'Response'. @continue@+-- turns such a function into a corresponding CPS version. For example:+--+-- @+-- sitemap :: Monad m => Routes a m ()+-- sitemap = do+-- get "\/f\/:foo" (/continue/ f) $ capture "foo"+-- get "\/g\/:foo" g $ capture "foo"+--+-- f :: Monad m => Int -> m Response+-- f x = ...+--+-- g :: Monad m => Int -> Continue m -> m ResponseReceived+-- g x k = k $ ...+-- @+continue :: Monad m => (a -> m Response) -> a -> Continue m -> m ResponseReceived+continue f a k = f a >>= k+{-# INLINE continue #-}+ -- | Run the 'Routes' monad and return the handlers per path.-prepare :: Monad m => Routes a m b -> [(ByteString, RoutingReq -> m Response)]+prepare :: Monad m => Routes a m b -> [(ByteString, App m)] prepare (Routes rr) = let s = execState rr zero in map (\g -> (_path (L.head g), select (renderfn s) g)) (normalise (routes s))@@ -207,37 +245,37 @@ -- (2) Evaluate 'Route' predicates. -- (3) Pick the first one which is 'Good', or else respond with status -- and message of the first one.-select :: Monad m => Renderer -> [Route a m] -> RoutingReq -> m Response-select render rr req = do+select :: forall a m. Monad m => Renderer -> [Route a m] -> App m+select render rr req k = do let ms = filter ((method req ==) . _method) rr if null ms- then return $ respond render e405 [(allow, validMethods)]+ then k $ respond render e405 [(allow, validMethods)] else evalAll ms where- allow :: HeaderName- allow = mk "Allow"-- validMethods :: ByteString- validMethods = C.intercalate "," $ nub (C.pack . show . _method <$> rr)-- evalAll :: Monad m => [Route a m] -> m Response+ evalAll :: [Route a m] -> m ResponseReceived evalAll rs = let (n, y) = partitionEithers $ foldl' evalSingle [] rs in if null y- then return $ respond render (L.head n) []+ then k $ respond render (L.head n) [] else closest y - evalSingle :: Monad m => [Either Error (Handler m)] -> Route a m -> [Either Error (Handler m)]+ evalSingle :: [Either Error (Handler m)] -> Route a m -> [Either Error (Handler m)] evalSingle rs r = case _pred r of Pack p h -> case p req of Fail m -> Left m : rs- Okay d v -> Right (Handler d (h v)) : rs+ Okay d v -> Right (Handler d (h v k)) : rs - closest :: Monad m => [Handler m] -> m Response+ closest :: [Handler m] -> m ResponseReceived closest hh = case map _handler . sortBy (compare `on` _delta) $ hh of- [] -> return $ responseBuilder status404 [] mempty+ [] -> k $ responseBuilder status404 [] mempty h:_ -> h++ validMethods :: ByteString+ validMethods = C.intercalate "," $ nub (C.pack . show . _method <$> rr)++allow :: HeaderName+allow = mk "Allow" respond :: Renderer -> Error -> ResponseHeaders -> Response respond f e h = responseLBS (status e) h (fromMaybe mempty (f e))
test/Tests/Wai/Route.hs view
@@ -24,6 +24,8 @@ import qualified Data.ByteString.Lazy as Lazy +type ApplicationM m = Request -> (Response -> m ResponseReceived) -> m ResponseReceived+ tests :: TestTree tests = testGroup "Network.Wai.Routing" [ testCase "Sitemap" testSitemap@@ -38,6 +40,7 @@ ["/a", "/b", "/c", "/d", "/e", "/f", "/g", "/h"] @=? map fst routes let handler = route routes+ testEndpointA handler testEndpointB handler testEndpointC handler@@ -48,7 +51,7 @@ sitemap :: Routes Int IO () sitemap = do- get "/a" handlerA $+ get "/a" (continue handlerA) $ accept "application" "json" .&. (query "name" .|. query "nick") .&. query "foo" attach 0@@ -58,31 +61,31 @@ attach 1 - get "/c" handlerC $+ get "/c" (continue handlerC) $ opt (query "foo") attach 2 - get "/d" handlerD $+ get "/d" (continue handlerD) $ def 0 (query "foo") attach 3 - get "/e" handlerE $+ get "/e" (continue handlerE) $ def 0 (header "foo") attach 4 - get "/f" handlerF $+ get "/f" (continue handlerF) $ query "foo" attach 5 - get "/g" handlerG true+ get "/g" (continue handlerG) true attach 6 - get "/h" handlerH $+ get "/h" (continue handlerH) $ cookie "user" .&. cookie "age" attach 7@@ -90,8 +93,8 @@ handlerA :: Media "application" "json" ::: Int ::: ByteString -> IO Response handlerA (_ ::: i ::: _) = writeText (fromString . show $ i) -handlerB :: Int -> IO Response-handlerB baz = writeText (fromString . show $ baz)+handlerB :: Int -> Continue IO -> IO ResponseReceived+handlerB baz k = k $ responseLBS status200 [] (fromString . show $ baz) handlerC :: Maybe Int -> IO Response handlerC foo = writeText (fromString . show $ foo)@@ -112,113 +115,113 @@ handlerH (user ::: age) = writeText $ "user = " <> user <> ", age = " <> fromString (show age) -testEndpointA :: Application -> Assertion+testEndpointA :: ApplicationM IO -> Assertion testEndpointA f = do let rq = defaultRequest { rawPathInfo = "/a" } - rs0 <- f $ withHeader "Accept" "foo/bar" rq+ rs0 <- apply f $ withHeader "Accept" "foo/bar" rq status406 @=? responseStatus rs0 - rs1 <- f $ json rq+ rs1 <- apply f $ json rq status400 @=? responseStatus rs1 - rs2 <- f . json . withQuery "name" "x" $ rq+ rs2 <- apply f $ json . withQuery "name" "x" $ rq status400 @=? responseStatus rs2 - rs3 <- f . json . withQuery "name" "123" . withQuery "foo" "\"z\"" $ rq+ rs3 <- apply f $ json . withQuery "name" "123" . withQuery "foo" "\"z\"" $ rq status200 @=? responseStatus rs3 -testEndpointB :: Application -> Assertion+testEndpointB :: ApplicationM IO -> Assertion testEndpointB f = do let rq = defaultRequest { rawPathInfo = "/b" } - rs0 <- f rq+ rs0 <- apply f rq status400 @=? responseStatus rs0 "'baz' not-available [query]" @=? responseBody rs0 - rs1 <- f . withQuery "baz" "abc" $ rq+ rs1 <- apply f $ withQuery "baz" "abc" $ rq status400 @=? responseStatus rs1 "'baz' type-error [query] -- Failed reading: Invalid Int" @=? responseBody rs1 - rs2 <- f . withQuery "baz" "abc" . withQuery "baz" "123" $ rq+ rs2 <- apply f $ withQuery "baz" "abc" . withQuery "baz" "123" $ rq status200 @=? responseStatus rs2 "123" @=? responseBody rs2 -testEndpointC :: Application -> Assertion+testEndpointC :: ApplicationM IO -> Assertion testEndpointC f = do let rq = defaultRequest { rawPathInfo = "/c" } - rs0 <- f rq+ rs0 <- apply f rq status200 @=? responseStatus rs0 "Nothing" @=? responseBody rs0 - rs1 <- f . withQuery "foo" "abc" . withQuery "foo" "123" $ rq+ rs1 <- apply f $ withQuery "foo" "abc" . withQuery "foo" "123" $ rq status200 @=? responseStatus rs1 "Just 123" @=? responseBody rs1 - rs2 <- f . withQuery "foo" "abc" $ rq+ rs2 <- apply f $ withQuery "foo" "abc" $ rq status400 @=? responseStatus rs2 "'foo' type-error [query] -- Failed reading: Invalid Int" @=? responseBody rs2 -testEndpointD :: Application -> Assertion+testEndpointD :: ApplicationM IO -> Assertion testEndpointD f = do let rq = defaultRequest { rawPathInfo = "/d" } - rs0 <- f rq+ rs0 <- apply f rq status200 @=? responseStatus rs0 "0" @=? responseBody rs0 - rs1 <- f . withQuery "foo" "xxx" . withQuery "foo" "42" $ rq+ rs1 <- apply f $ withQuery "foo" "xxx" . withQuery "foo" "42" $ rq status200 @=? responseStatus rs1 "42" @=? responseBody rs1 - rs2 <- f . withQuery "foo" "yyy" $ rq+ rs2 <- apply f $ withQuery "foo" "yyy" $ rq status400 @=? responseStatus rs2 "'foo' type-error [query] -- Failed reading: Invalid Int" @=? responseBody rs2 -testEndpointE :: Application -> Assertion+testEndpointE :: ApplicationM IO -> Assertion testEndpointE f = do let rq = defaultRequest { rawPathInfo = "/e" } - rs0 <- f rq+ rs0 <- apply f rq status200 @=? responseStatus rs0 "0" @=? responseBody rs0 - rs1 <- f $ withHeader "foo" "42" rq+ rs1 <- apply f $ withHeader "foo" "42" rq status200 @=? responseStatus rs1 "42" @=? responseBody rs1 - rs2 <- f $ withHeader "foo" "abc" rq+ rs2 <- apply f $ withHeader "foo" "abc" rq status400 @=? responseStatus rs2 "'foo' type-error [header] -- Failed reading: Invalid Int" @=? responseBody rs2 -testEndpointF :: Application -> Assertion+testEndpointF :: ApplicationM IO -> Assertion testEndpointF f = do let rq = defaultRequest { rawPathInfo = "/f" } - rs0 <- f . withQuery "foo" "1,2,3,4" $ rq+ rs0 <- apply f $ withQuery "foo" "1,2,3,4" $ rq status200 @=? responseStatus rs0 "10" @=? responseBody rs0 -testEndpointH :: Application -> Assertion+testEndpointH :: ApplicationM IO -> Assertion testEndpointH f = do let rq = defaultRequest { rawPathInfo = "/h" } - rs0 <- f rq+ rs0 <- apply f rq status400 @=? responseStatus rs0 "'user' not-available [cookie]" @=? responseBody rs0 - rs1 <- f . withHeader "Cookie" "user=joe" $ rq+ rs1 <- apply f $ withHeader "Cookie" "user=joe" $ rq status400 @=? responseStatus rs1 "'age' not-available [cookie]" @=? responseBody rs1 - rs2 <- f . withHeader "Cookie" "user=joe; age=42" $ rq+ rs2 <- apply f $ withHeader "Cookie" "user=joe; age=42" $ rq status200 @=? responseStatus rs2 "user = joe, age = 42" @=? responseBody rs2 @@ -233,8 +236,8 @@ sitemapMedia :: Routes a IO () sitemapMedia = do- get "/media" handlerJson $ accept "application" "json"- get "/media" handlerThrift $ accept "application" "x-thrift"+ get "/media" (continue handlerJson) $ accept "application" "json"+ get "/media" (continue handlerThrift) $ accept "application" "x-thrift" handlerJson :: Media "application" "json" -> IO Response handlerJson _ = writeText "application/json"@@ -242,8 +245,8 @@ handlerThrift :: Media "application" "x-thrift" -> IO Response handlerThrift _ = writeText "application/x-thrift" -expectMedia :: ByteString -> ByteString -> (RoutingReq -> IO Response) -> Assertion+expectMedia :: ByteString -> ByteString -> App IO -> Assertion expectMedia h res m = do let rq = defaultRequest { rawPathInfo = "/media" }- rs <- m . fromReq [] . fromRequest . withHeader "Accept" h $ rq+ rs <- apply m $ fromReq [] . fromRequest . withHeader "Accept" h $ rq Lazy.fromStrict res @=? responseBody rs
test/Tests/Wai/Util.hs view
@@ -2,8 +2,10 @@ module Tests.Wai.Util where +import Control.Monad (void) import Data.ByteString (ByteString) import Data.CaseInsensitive (CI)+import Data.IORef import Network.Wai import Network.Wai.Internal import Network.HTTP.Types@@ -29,3 +31,9 @@ writeText :: Lazy.ByteString -> IO Response writeText = return . responseLBS status200 []++apply :: (a -> (Response -> IO ResponseReceived) -> IO ResponseReceived) -> a -> IO Response+apply f r = do+ ref <- newIORef undefined+ void $ f r $ \x -> writeIORef ref x >> return ResponseReceived+ readIORef ref
wai-routing.cabal view
@@ -1,5 +1,5 @@ name: wai-routing-version: 0.8+version: 0.9 synopsis: Declarative routing for WAI. license: OtherLicense license-file: LICENSE@@ -40,10 +40,10 @@ > >start :: Monad m => Routes a m () >start = do- > get "/user/:name" fetchUser $+ > get "/user/:name" (continue fetchUser) $ > capture "name" >- > get "/user/find" findUser $+ > get "/user/find" (continue findUser) $ > query "byName" ||| query "byId" > > delete "/user/:name" rmUser $@@ -56,8 +56,8 @@ >findUser (Left name) = ... >findUser (Right ident) = ... >- >rmUser :: Monad m => Text ::: Maybe Int -> m Response- >rmUser (name ::: foo) = ...+ >rmUser :: Monad m => Text ::: Maybe Int -> Continue m -> m ResponseReceived+ >rmUser (name ::: foo) k = k $ ... source-repository head type: git@@ -76,7 +76,7 @@ Network.Wai.Routing.Predicate build-depends:- attoparsec >= 0.10 && < 0.12+ attoparsec >= 0.10 && < 0.13 , base == 4.* , bytestring >= 0.9 && < 0.11 , bytestring-from >= 0.2 && < 0.4@@ -84,9 +84,9 @@ , case-insensitive >= 1.1 && < 1.3 , http-types == 0.8.* , transformers >= 0.3 && < 0.5- , wai >= 2.0 && < 2.2- , wai-predicates >= 0.6 && < 0.7- , wai-route == 0.1.*+ , wai == 3.0.*+ , wai-predicates == 0.7.*+ , wai-route == 0.2.* test-suite wai-routing-tests type: exitcode-stdio-1.0