diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/examples/eval-routing.hs b/examples/eval-routing.hs --- a/examples/eval-routing.hs +++ b/examples/eval-routing.hs @@ -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 $ diff --git a/src/Network/Wai/Routing/Route.hs b/src/Network/Wai/Routing/Route.hs --- a/src/Network/Wai/Routing/Route.hs +++ b/src/Network/Wai/Routing/Route.hs @@ -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)) diff --git a/test/Tests/Wai/Route.hs b/test/Tests/Wai/Route.hs --- a/test/Tests/Wai/Route.hs +++ b/test/Tests/Wai/Route.hs @@ -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 diff --git a/test/Tests/Wai/Util.hs b/test/Tests/Wai/Util.hs --- a/test/Tests/Wai/Util.hs +++ b/test/Tests/Wai/Util.hs @@ -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 diff --git a/wai-routing.cabal b/wai-routing.cabal --- a/wai-routing.cabal +++ b/wai-routing.cabal @@ -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