ccadba8 · typeable/servant

git.iko.soy/typeable/servant

on master help sign in

Cleanup errorspec description of routing, changelog.

ccadba8Julian K. Arni11 years ago

servant-examples/auth-combinator/auth-combinator.hs+2−2

compare with master

unifiedsplit

@@ -32,12 +32,12 @@ instance HasServer rest => HasServer (AuthProtected :> rest) where

32 route Proxy a = WithRequest $ \ request ->

33 route (Proxy :: Proxy rest) $ do

34 case lookup "Cookie" (requestHeaders request) of

35− Nothing -> return $! failFatallyWith err401 { errBody = "Missing auth header" }

35+ Nothing -> return $! FailFatal err401 { errBody = "Missing auth header" }

36 Just v -> do

37 authGranted <- isGoodCookie v

38 if authGranted

39 then a

40− else return $! failFatallyWith err403 { errBody = "Invalid cookie" }

40+ else return $ FailFatal err403 { errBody = "Invalid cookie" }

42type PrivateAPI = Get '[JSON] [PrivateData]

servant-server/CHANGELOG.md+5

@@ -5,6 +5,11 @@ HEAD

5* Drop `EitherT` in favor of `ExceptT`

6* Use `http-api-data` instead of `Servant.Common.Text`

7* Remove matrix params.

8+* Remove `RouteMismatch`.

9+* Redefined constructors of `RouteResult`.

10+* Add `failFatallyWith`.

11+* Make all (framework-generated) HTTP errors except 404 and 405 not try other

12+ handlers.

90.4.1

140.4.1

10-----

15-----

servant-server/src/Servant/Server.hs+1−1

@@ -103,7 +103,7 @@ import Servant.Server.Internal.Enter

103-- > main = Network.Wai.Handler.Warp.run 8080 app

104--

105serve :: HasServer layout => Proxy layout -> Server layout -> Application

106−serve p server = toApplication (runRouter (route p (return (HandlerVal server))))

106+serve p server = toApplication (runRouter (route p (return (Route server))))

107

108

109-- Documentation

servant-server/src/Servant/Server/Internal.hs+29−29

@@ -1,15 +1,15 @@

1−{-# LANGUAGE CPP #-}

1+{-# LANGUAGE CPP #-}

2−{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE FlexibleContexts #-}

3+{-# LANGUAGE FlexibleContexts #-}

4−{-# LANGUAGE FlexibleInstances #-}

4+{-# LANGUAGE FlexibleInstances #-}

5{-# LANGUAGE GeneralizedNewtypeDeriving #-}

6−{-# LANGUAGE OverloadedStrings #-}

6+{-# LANGUAGE OverloadedStrings #-}

7−{-# LANGUAGE PolyKinds #-}

7+{-# LANGUAGE PolyKinds #-}

8−{-# LANGUAGE ScopedTypeVariables #-}

8+{-# LANGUAGE ScopedTypeVariables #-}

9−{-# LANGUAGE TypeFamilies #-}

9+{-# LANGUAGE TypeFamilies #-}

10−{-# LANGUAGE TypeOperators #-}

10+{-# LANGUAGE TypeOperators #-}

11#if !MIN_VERSION_base(4,8,0)

12−{-# LANGUAGE OverlappingInstances #-}

12+{-# LANGUAGE OverlappingInstances #-}

13#endif

15module Servant.Server.Internal

@@ -26,9 +26,9 @@ import Control.Monad.Trans.Except (ExceptT)

26import qualified Data.ByteString as B

27import qualified Data.ByteString.Lazy as BL

28import qualified Data.Map as M

29−import Data.Maybe (mapMaybe, fromMaybe)

29+import Data.Maybe (fromMaybe, mapMaybe)

30import Data.String (fromString)

31−import Data.String.Conversions (cs, (<>), ConvertibleStrings)

31+import Data.String.Conversions (ConvertibleStrings, cs, (<>))

32import Data.Text (Text)

33import Data.Typeable

34import GHC.TypeLits (KnownSymbol, symbolVal)

@@ -47,8 +47,8 @@ import Servant.API ((:<|>) (..), (:>), Capture,

47import Servant.API.ContentTypes (AcceptHeader (..),

48 AllCTRender (..),

49 AllCTUnrender (..))

50−import Servant.API.ResponseHeaders (Headers, getResponse, GetHeaders,

50+import Servant.API.ResponseHeaders (GetHeaders, Headers, getHeaders,

51− getHeaders)

51+ getResponse)

53import Servant.Server.Internal.Router

54import Servant.Server.Internal.RoutingApplication

@@ -114,7 +114,7 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout)

114

115 route Proxy subserver =

116 DynamicRouter $ \ first -> case captured captureProxy first of

117− Nothing -> LeafRouter (\_ r -> r $ failWith err404)

117+ Nothing -> LeafRouter (\_ r -> r $ Fail err404)

118 Just v -> route (Proxy :: Proxy sublayout) (feedTo subserver v)

119

120 where captureProxy = Proxy :: Proxy (Capture capture a)

@@ -130,8 +130,8 @@ processMethodRouter :: forall a. ConvertibleStrings a B.ByteString

130 -> Maybe [(HeaderName, B.ByteString)]

131 -> Request -> RouteResult Response

132processMethodRouter handleA status method headers request = case handleA of

133− Nothing -> failFatallyWith err406

133+ Nothing -> FailFatal err406

134− Just (contentT, body) -> succeedWith $ responseLBS status hdrs bdy

134+ Just (contentT, body) -> Route $! responseLBS status hdrs bdy

135 where

136 bdy = if allowedMethodHead method request then "" else body

137 hdrs = (hContentType, cs contentT) : (fromMaybe [] headers)

@@ -149,8 +149,8 @@ methodRouter method proxy status action = LeafRouter route'

149 handleA = handleAcceptH proxy (AcceptHeader accH) output

150 processMethodRouter handleA status method Nothing request

151 | pathIsEmpty request && requestMethod request /= method =

152− respond $ failWith err405

152+ respond $ Fail err405

153− | otherwise = respond $ failWith err404

153+ | otherwise = respond $ Fail err404

154

155methodRouterHeaders :: (GetHeaders (Headers h v), AllCTRender ctypes v)

156 => Method -> Proxy ctypes -> Status

@@ -166,8 +166,8 @@ methodRouterHeaders method proxy status action = LeafRouter route'

166 handleA = handleAcceptH proxy (AcceptHeader accH) (getResponse output)

167 processMethodRouter handleA status method (Just headers) request

168 | pathIsEmpty request && requestMethod request /= method =

169− respond $ failWith err405

169+ respond $ Fail err405

170− | otherwise = respond $ failWith err404

170+ | otherwise = respond $ Fail err404

171

172methodRouterEmpty :: Method

173 -> IO (RouteResult (ExceptT ServantErr IO ()))

@@ -177,10 +177,10 @@ methodRouterEmpty method action = LeafRouter route'

177 route' request respond

178 | pathIsEmpty request && allowedMethod method request = do

179 runAction action respond $ \ () ->

180− succeedWith $ responseLBS noContent204 [] ""

180+ Route $! responseLBS noContent204 [] ""

181 | pathIsEmpty request && requestMethod request /= method =

182− respond $ failWith err405

182+ respond $ Fail err405

183− | otherwise = respond $ failWith err404

183+ | otherwise = respond $ Fail err404

184

185-- | If you have a 'Delete' endpoint in your API,

186-- the handler for this endpoint is meant to delete

@@ -557,9 +557,9 @@ instance HasServer Raw where

557 route Proxy rawApplication = LeafRouter $ \ request respond -> do

558 r <- rawApplication

559 case r of

560− HandlerVal app -> app request (respond . succeedWith)

560+ Route app -> app request (respond . Route)

561− Retriable e -> respond $ failWith e

561+ Fail a -> respond $ Fail a

562− NonRetriable e -> respond $! failFatallyWith e

562+ FailFatal e -> respond $ FailFatal e

563

564-- | If you use 'ReqBody' in one of the endpoints for your API,

565-- this automatically requires your server-side handler to be a function

@@ -599,8 +599,8 @@ instance ( AllCTUnrender list a, HasServer sublayout

599 mrqbody <- handleCTypeH (Proxy :: Proxy list) (cs contentTypeH)

600 <$> lazyRequestBody request

601 case mrqbody of

602− Nothing -> return $! failFatallyWith err415

602+ Nothing -> return $ FailFatal err415

603− Just (Left e) -> return $! failFatallyWith err400 { errBody = cs e }

603+ Just (Left e) -> return $ FailFatal err400 { errBody = cs e }

604 Just (Right v) -> feedTo subserver v

605

606-- | Make sure the incoming request starts with @"/path"@, strip it and

servant-server/src/Servant/Server/Internal/Router.hs+12−14

@@ -1,10 +1,9 @@

1{-# LANGUAGE DeriveFunctor #-}

2−

2+{-# LANGUAGE CPP #-}

3module Servant.Server.Internal.Router where

5import Data.Map (Map)

6import qualified Data.Map as M

7−import Data.Monoid ((<>))

8import Data.Text (Text)

7import Data.Text (Text)

9import Network.Wai (Request, Response, pathInfo)

8import Network.Wai (Request, Response, pathInfo)

10import Servant.Server.Internal.ServantErr

9import Servant.Server.Internal.ServantErr

@@ -65,24 +64,23 @@ runRouter (StaticRouter table) request respond =

65 | Just router <- M.lookup first table

64 | Just router <- M.lookup first table

66 -> let request' = request { pathInfo = rest }

65 -> let request' = request { pathInfo = rest }

67 in runRouter router request' respond

66 in runRouter router request' respond

68− _ -> respond $ failWith err404

67+ _ -> respond $ Fail err404

69runRouter (DynamicRouter fun) request respond =

68runRouter (DynamicRouter fun) request respond =

70 case pathInfo request of

69 case pathInfo request of

71 first : rest

70 first : rest

72 -> let request' = request { pathInfo = rest }

71 -> let request' = request { pathInfo = rest }

73 in runRouter (fun first) request' respond

72 in runRouter (fun first) request' respond

74− _ -> respond $ failWith err404

73+ _ -> respond $ Fail err404

75runRouter (LeafRouter app) request respond = app request respond

74runRouter (LeafRouter app) request respond = app request respond

76runRouter (Choice r1 r2) request respond =

75runRouter (Choice r1 r2) request respond =

77− runRouter r1 request $ \ mResponse1 ->

76+ runRouter r1 request $ \ mResponse1 -> case mResponse1 of

78− if isMismatch mResponse1

79− then runRouter r2 request $ \ mResponse2 ->

77+ Fail _ -> runRouter r2 request $ \ mResponse2 ->

80− respond (highestPri mResponse1 mResponse2)

78+ respond (highestPri mResponse1 mResponse2)

81− else respond mResponse1

79+ _ -> respond mResponse1

82 where

80 where

83− highestPri (Retriable r1) (Retriable r2) =

81+ highestPri (Fail e1) (Fail e2) =

84− if errHTTPCode r1 == 404 && errHTTPCode r2 /= 404

82+ if errHTTPCode e1 == 404 && errHTTPCode e2 /= 404

85− then (Retriable r2)

83+ then Fail e2

86− else (Retriable r1)

84+ else Fail e1

87− highestPri (Retriable _) y = y

85+ highestPri (Fail _) y = y

88 highestPri x _ = x

86 highestPri x _ = x

servant-server/src/Servant/Server/Internal/RoutingApplication.hs+16−33

@@ -1,6 +1,5 @@

1{-# LANGUAGE CPP #-}

2{-# LANGUAGE DeriveFunctor #-}

3−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

4{-# LANGUAGE OverloadedStrings #-}

3{-# LANGUAGE OverloadedStrings #-}

5{-# LANGUAGE TypeOperators #-}

4{-# LANGUAGE TypeOperators #-}

6module Servant.Server.Internal.RoutingApplication where

5module Servant.Server.Internal.RoutingApplication where

@@ -28,10 +27,10 @@ type RoutingApplication =

29-- | A wrapper around @'Either' 'RouteMismatch' a@.

28-- | A wrapper around @'Either' 'RouteMismatch' a@.

30data RouteResult a =

29data RouteResult a =

31− Retriable ServantErr -- ^ Keep trying other paths. The @ServantErr@

30+ Fail ServantErr -- ^ Keep trying other paths. The @ServantErr@

32 -- should only be 404 or 405.

31 -- should only be 404 or 405.

33− | NonRetriable ServantErr -- ^ Stop trying.

32+ | FailFatal ServantErr -- ^ Don't other paths.

34− | HandlerVal a

33+ | Route a

35 deriving (Eq, Show, Read, Functor)

34 deriving (Eq, Show, Read, Functor)

37data ReqBodyState = Uncalled

36data ReqBodyState = Uncalled

@@ -64,9 +63,9 @@ toApplication ra request respond = do

64 ra request{ requestBody = memoReqBody } routingRespond

63 ra request{ requestBody = memoReqBody } routingRespond

65 where

64 where

66 routingRespond :: RouteResult Response -> IO ResponseReceived

65 routingRespond :: RouteResult Response -> IO ResponseReceived

67− routingRespond (Retriable err) = respond $! responseServantErr err

66+ routingRespond (Fail err) = respond $! responseServantErr err

68− routingRespond (NonRetriable err) = respond $! responseServantErr err

67+ routingRespond (FailFatal err) = respond $! responseServantErr err

69− routingRespond (HandlerVal v) = respond v

68+ routingRespond (Route v) = respond v

71runAction :: IO (RouteResult (ExceptT ServantErr IO a))

70runAction :: IO (RouteResult (ExceptT ServantErr IO a))

72 -> (RouteResult Response -> IO r)

71 -> (RouteResult Response -> IO r)

@@ -74,39 +73,23 @@ runAction :: IO (RouteResult (ExceptT ServantErr IO a))

74 -> IO r

73 -> IO r

75runAction action respond k = action >>= go >>= respond

74runAction action respond k = action >>= go >>= respond

76 where

75 where

77− go (Retriable e) = return $! Retriable e

76+ go (Fail e) = return $ Fail e

78− go (NonRetriable e) = return . succeedWith $! responseServantErr e

77+ go (FailFatal e) = return $ FailFatal e

79− go (HandlerVal a) = do

78+ go (Route a) = do

80 e <- runExceptT a

79 e <- runExceptT a

81 case e of

80 case e of

82− Left err -> return . succeedWith $! responseServantErr err

81+ Left err -> return . Route $ responseServantErr err

83 Right x -> return $! k x

82 Right x -> return $! k x

85feedTo :: IO (RouteResult (a -> b)) -> a -> IO (RouteResult b)

84feedTo :: IO (RouteResult (a -> b)) -> a -> IO (RouteResult b)

86feedTo f x = (($ x) <$>) <$> f

85feedTo f x = (($ x) <$>) <$> f

88extractL :: RouteResult (a :<|> b) -> RouteResult a

87extractL :: RouteResult (a :<|> b) -> RouteResult a

89−extractL (HandlerVal (a :<|> _)) = HandlerVal a

88+extractL (Route (a :<|> _)) = Route a

90−extractL (Retriable x) = Retriable x

89+extractL (Fail x) = Fail x

91−extractL (NonRetriable x) = NonRetriable x

90+extractL (FailFatal x) = FailFatal x

93extractR :: RouteResult (a :<|> b) -> RouteResult b

92extractR :: RouteResult (a :<|> b) -> RouteResult b

94−extractR (HandlerVal (_ :<|> b)) = HandlerVal b

93+extractR (Route (_ :<|> b)) = Route b

95−extractR (Retriable x) = Retriable x

94+extractR (Fail x) = Fail x

96−extractR (NonRetriable x) = NonRetriable x

95+extractR (FailFatal x) = FailFatal x

97−

98−-- | Fail with a @ServantErr@, but keep trying other paths and.

99−failWith :: ServantErr -> RouteResult a

100−failWith = Retriable

101−

102−-- | Fail with immediately @ServantErr@.

103−failFatallyWith :: ServantErr -> RouteResult a

104−failFatallyWith = NonRetriable

105−

106−-- | Return a value, and don't try other paths.

107−succeedWith :: a -> RouteResult a

108−succeedWith = HandlerVal

109−

110−isMismatch :: RouteResult a -> Bool

111−isMismatch (Retriable _) = True

112−isMismatch _ = False

servant-server/test/Servant/Server/ErrorSpec.hs+70−16

@@ -6,32 +6,38 @@

6module Servant.Server.ErrorSpec (spec) where

8import Data.Aeson (encode)

9−import qualified Data.ByteString.Lazy.Char8 as BC

9+import qualified Data.ByteString.Lazy.Char8 as BCL

10+import qualified Data.ByteString.Char8 as BC

10import Data.Proxy

11import Data.Proxy

11import Network.HTTP.Types (hAccept, hContentType, methodGet,

12import Network.HTTP.Types (hAccept, hContentType, methodGet,

12− methodPost)

13+ methodPost, methodPut)

13import Test.Hspec

14import Test.Hspec

14import Test.Hspec.Wai

15import Test.Hspec.Wai

16import Servant

17import Servant

20+-- The semantics of routing and handling requests should be as follows:

21+--

19−-- 1) Check whether one or more endpoints have the right path. Otherwise return 404.

22+-- 1) Check whether one or more endpoints have the right path. Otherwise

23+-- return 404.

20−-- 2) Check whether the one of those have the right method. Otherwise return

24+-- 2) Check whether the one of those have the right method. Otherwise return

21−-- 405. If so, pick the first. We've now commited to calling at most one handler. *

25+-- 405. If so, pick the first. We've now committed to calling at most one

26+-- handler.

22−-- 3) Check whether the Content-Type is known. Otherwise return 415.

27+-- 3) Check whether the Content-Type is known. Otherwise return 415.

23−-- 4) Check whether that one deserializes the body. Otherwise return 400. If there

28+-- 4) Check whether that one deserializes the body. Otherwise return 400. If

24−-- was no Content-Type, try the first one of the API content-type list.

29+-- there was no Content-Type, try the first one of the API content-type list.

25−-- 5) Check whether the request is authorized. Otherwise return a 401.

30+-- 5) Check whether the request is authorized. Otherwise return a 401.

26−-- 6) Check whether the request is forbidden. If so return 403.

31+-- 6) Check whether the request is forbidden. If so return 403.

27−-- 7) Check whether the request has a known Accept. Otherwise return 406.

32+-- 7) Check whether the request has a known Accept. Otherwise return 406.

28−-- 8) Check whether Accept-Language, Accept-Charset and Accept-Encoding exist and

33+-- 8) Check whether Accept-Language, Accept-Charset and Accept-Encoding

29−-- match. We can follow the webmachine order here.

34+-- exist and match. We can follow the webmachine order here.

30−-- 9) Call the handler. Whatever it returns, we return.

35+-- 9) Call the handler. Whatever it returns, we return.

32spec :: Spec

37spec :: Spec

33spec = describe "HTTP Errors" $ do

38spec = describe "HTTP Errors" $ do

34 errorOrderSpec

39 errorOrderSpec

40+ prioErrorsSpec

35 errorRetrySpec

41 errorRetrySpec

36 errorChoiceSpec

42 errorChoiceSpec

@@ -83,6 +89,52 @@ errorOrderSpec = describe "HTTP error order"

83 request goodMethod goodUrl [goodContentType, badAccept] goodBody

89 request goodMethod goodUrl [goodContentType, badAccept] goodBody

84 `shouldRespondWith` 406

90 `shouldRespondWith` 406

92+type PrioErrorsApi = ReqBody '[JSON] Integer :> "foo" :> Get '[JSON] Integer

93+

94+prioErrorsApi :: Proxy PrioErrorsApi

95+prioErrorsApi = Proxy

96+

97+-- Check whether matching continues even if a 'ReqBody' or similar construct

98+-- is encountered early in a path. We don't want to see a complaint about the

99+-- request body unless the path actually matches.

100+prioErrorsSpec :: Spec

101+prioErrorsSpec = describe "PrioErrors" $ do

102+ let server = return

103+ with (return $ serve prioErrorsApi server) $ do

104+ let check (mdescr, method) path (cdescr, ctype, body) resp =

105+ it fulldescr $

106+ Test.Hspec.Wai.request method path [(hContentType, ctype)] body

107+ `shouldRespondWith` resp

108+ where

109+ fulldescr = "returns " ++ show (matchStatus resp) ++ " on " ++ mdescr

110+ ++ " " ++ (BC.unpack path) ++ " (" ++ cdescr ++ ")"

111+

112+ get' = ("GET", methodGet)

113+ put' = ("PUT", methodPut)

114+

115+ txt = ("text" , "text/plain;charset=utf8" , "42" )

116+ ijson = ("invalid json", "application/json;charset=utf8", "invalid" )

117+ vjson = ("valid json" , "application/json;charset=utf8", encode (5 :: Int))

118+

119+ check get' "/" txt 404

120+ check get' "/bar" txt 404

121+ check get' "/foo" txt 415

122+ check put' "/" txt 404

123+ check put' "/bar" txt 404

124+ check put' "/foo" txt 405

125+ check get' "/" ijson 404

126+ check get' "/bar" ijson 404

127+ check get' "/foo" ijson 400

128+ check put' "/" ijson 404

129+ check put' "/bar" ijson 404

130+ check put' "/foo" ijson 405

131+ check get' "/" vjson 404

132+ check get' "/bar" vjson 404

133+ check get' "/foo" vjson 200

134+ check put' "/" vjson 404

135+ check put' "/bar" vjson 404

136+ check put' "/foo" vjson 405

137+

86-- }}}

138-- }}}

87------------------------------------------------------------------------------

139------------------------------------------------------------------------------

88-- * Error Retry {{{

140-- * Error Retry {{{

@@ -190,8 +242,10 @@ errorChoiceSpec = describe "Multiple handlers return errors"

190-- * Instances {{{

242-- * Instances {{{

191

243

192instance MimeUnrender PlainText Int where

244instance MimeUnrender PlainText Int where

193− mimeUnrender _ = Right . read . BC.unpack

245+ mimeUnrender _ = Right . read . BCL.unpack

194

246

195instance MimeRender PlainText Int where

247instance MimeRender PlainText Int where

196− mimeRender _ = BC.pack . show

248+ mimeRender _ = BCL.pack . show

197-- }}}

249-- }}}

250+--

251+

servant-server/test/Servant/ServerSpec.hs+19−50

@@ -1,11 +1,20 @@

1+<<<<<<< HEAD

1{-# LANGUAGE CPP #-}

2{-# LANGUAGE CPP #-}

2{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE DeriveGeneric #-}

4{-# LANGUAGE DeriveGeneric #-}

5+=======

6+{-# LANGUAGE DataKinds #-}

7+{-# LANGUAGE DeriveGeneric #-}

8+{-# LANGUAGE FlexibleInstances #-}

9+>>>>>>> Review fixes

4{-# LANGUAGE OverloadedStrings #-}

10{-# LANGUAGE OverloadedStrings #-}

5{-# LANGUAGE ScopedTypeVariables #-}

11{-# LANGUAGE ScopedTypeVariables #-}

6{-# LANGUAGE TypeOperators #-}

12{-# LANGUAGE TypeOperators #-}

7{-# LANGUAGE TypeSynonymInstances #-}

13{-# LANGUAGE TypeSynonymInstances #-}

14+<<<<<<< HEAD

8{-# LANGUAGE FlexibleInstances #-}

15{-# LANGUAGE FlexibleInstances #-}

16+=======

17+>>>>>>> Review fixes

10module Servant.ServerSpec where

19module Servant.ServerSpec where

@@ -32,6 +41,16 @@ import Network.Wai (Application, Request, pathInfo,

32import Network.Wai.Internal (Response(ResponseBuilder))

41import Network.Wai.Internal (Response(ResponseBuilder))

33import Network.Wai.Test (defaultRequest, request,

42import Network.Wai.Test (defaultRequest, request,

34 runSession, simpleBody)

43 runSession, simpleBody)

44+import Servant.API ((:<|>) (..), (:>), Capture, Delete,

45+ Get, Header (..), Headers,

46+ HttpVersion, IsSecure (..), JSON,

47+ MatrixFlag, MatrixParam,

48+ MatrixParams, Patch, PlainText,

49+ Post, Put, QueryFlag, QueryParam,

50+ QueryParams, Raw, RemoteHost,

51+ ReqBody, addHeader)

52+import Servant.Server (ServantErr (..), Server, err404,

53+ serve)

35import Test.Hspec (Spec, describe, it, shouldBe)

54import Test.Hspec (Spec, describe, it, shouldBe)

36import Test.Hspec.Wai (get, liftIO, matchHeaders,

55import Test.Hspec.Wai (get, liftIO, matchHeaders,

37 matchStatus, post, request,

56 matchStatus, post, request,

@@ -96,7 +115,6 @@ spec = do

96 headerSpec

115 headerSpec

97 rawSpec

116 rawSpec

98 unionSpec

117 unionSpec

99− prioErrorsSpec

100 routerSpec

118 routerSpec

101 responseHeadersSpec

119 responseHeadersSpec

102 miscReqCombinatorsSpec

120 miscReqCombinatorsSpec

@@ -526,55 +544,6 @@ responseHeadersSpec = describe "ResponseHeaders" $ do

526 Test.Hspec.Wai.request method "" [(hAccept, "crazy/mime")] ""

544 Test.Hspec.Wai.request method "" [(hAccept, "crazy/mime")] ""

527 `shouldRespondWith` 406

545 `shouldRespondWith` 406

528

546

529−type PrioErrorsApi = ReqBody '[JSON] Person :> "foo" :> Get '[JSON] Integer

530−

531−prioErrorsApi :: Proxy PrioErrorsApi

532−prioErrorsApi = Proxy

533−

534−-- | Test the relative priority of error responses from the server.

535−--

536−-- In particular, we check whether matching continues even if a 'ReqBody'

537−-- or similar construct is encountered early in a path. We don't want to

538−-- see a complaint about the request body unless the path actually matches.

539−--

540−prioErrorsSpec :: Spec

541−prioErrorsSpec = describe "PrioErrors" $ do

542− let server = return . age

543− with (return $ serve prioErrorsApi server) $ do

544− let check (mdescr, method) path (cdescr, ctype, body) resp =

545− it fulldescr $

546− Test.Hspec.Wai.request method path [(hContentType, ctype)] body

547− `shouldRespondWith` resp

548− where

549− fulldescr = "returns " ++ show (matchStatus resp) ++ " on " ++ mdescr

550− ++ " " ++ cs path ++ " (" ++ cdescr ++ ")"

551−

552− get' = ("GET", methodGet)

553− put' = ("PUT", methodPut)

554−

555− txt = ("text" , "text/plain;charset=utf8" , "42" )

556− ijson = ("invalid json", "application/json;charset=utf8", "invalid" )

557− vjson = ("valid json" , "application/json;charset=utf8", encode alice)

558−

559− check get' "/" txt 404

560− check get' "/bar" txt 404

561− check get' "/foo" txt 415

562− check put' "/" txt 404

563− check put' "/bar" txt 404

564− check put' "/foo" txt 405

565− check get' "/" ijson 404

566− check get' "/bar" ijson 404

567− check get' "/foo" ijson 400

568− check put' "/" ijson 404

569− check put' "/bar" ijson 404

570− check put' "/foo" ijson 405

571− check get' "/" vjson 404

572− check get' "/bar" vjson 404

573− check get' "/foo" vjson 200

574− check put' "/" vjson 404

575− check put' "/bar" vjson 404

576− check put' "/foo" vjson 405

577−

578

547

579routerSpec :: Spec

548routerSpec :: Spec

580routerSpec = do

549routerSpec = do