a3b5652 · servant · git.iko.soy

git.iko.soy/servant

on master help sign in

Refactor RouteResult.

a3b5652Julian K. Arni11 years ago

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

compare with master

unifiedsplit

@@ -5,6 +5,7 @@

5{-# LANGUAGE ScopedTypeVariables #-}

6{-# LANGUAGE TypeFamilies #-}

7{-# LANGUAGE TypeOperators #-}

8import Data.Aeson

9import Data.Aeson

9import Data.ByteString (ByteString)

10import Data.ByteString (ByteString)

10import Data.Text (Text)

11import Data.Text (Text)

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

31 route Proxy a = WithRequest $ \ request ->

32 route Proxy a = WithRequest $ \ request ->

32 route (Proxy :: Proxy rest) $ do

33 route (Proxy :: Proxy rest) $ do

33 case lookup "Cookie" (requestHeaders request) of

34 case lookup "Cookie" (requestHeaders request) of

34− Nothing -> return $ failWith $ HttpError status401 (Just "Missing auth header.")

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

35 Just v -> do

36 Just v -> do

36 authGranted <- isGoodCookie v

37 authGranted <- isGoodCookie v

37 if authGranted

38 if authGranted

38 then a

39 then a

39− else return $ failWith $ HttpError status403 (Just "Invalid cookie.")

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

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

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

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 (RR (Right server)))))

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

107

108

109-- Documentation

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

@@ -113,11 +113,10 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout)

113 a -> ServerT sublayout m

114

115 route Proxy subserver =

116− DynamicRouter $ \ first ->

117− route (Proxy :: Proxy sublayout)

118− (case captured captureProxy first of

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

119− Nothing -> return $ failWith NotFound

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

120− Just v -> feedTo subserver v)

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

119+

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

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

122

121

123allowedMethodHead :: Method -> Request -> Bool

122allowedMethodHead :: Method -> Request -> Bool

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

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

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

132 -> Request -> RouteResult Response

131 -> Request -> RouteResult Response

133processMethodRouter handleA status method headers request = case handleA of

132processMethodRouter handleA status method headers request = case handleA of

134− Nothing -> failWith UnsupportedMediaType

133+ Nothing -> failFatallyWith err406

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

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

136 where

135 where

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

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

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

150 handleA = handleAcceptH proxy (AcceptHeader accH) output

149 handleA = handleAcceptH proxy (AcceptHeader accH) output

151 processMethodRouter handleA status method Nothing request

150 processMethodRouter handleA status method Nothing request

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

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

153− respond $ failWith WrongMethod

152+ respond $ failWith err405

154− | otherwise = respond $ failWith NotFound

153+ | otherwise = respond $ failWith err404

155

154

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

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

157 => Method -> Proxy ctypes -> Status

156 => Method -> Proxy ctypes -> Status

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

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

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

168 processMethodRouter handleA status method (Just headers) request

167 processMethodRouter handleA status method (Just headers) request

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

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

170− respond $ failWith WrongMethod

169+ respond $ failWith err405

171− | otherwise = respond $ failWith NotFound

170+ | otherwise = respond $ failWith err404

172

171

173methodRouterEmpty :: Method

172methodRouterEmpty :: Method

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

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

@@ -180,8 +179,8 @@ methodRouterEmpty method action = LeafRouter route'

180 runAction action respond $ \ () ->

179 runAction action respond $ \ () ->

181 succeedWith $ responseLBS noContent204 [] ""

180 succeedWith $ responseLBS noContent204 [] ""

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

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

183− respond $ failWith WrongMethod

182+ respond $ failWith err405

184− | otherwise = respond $ failWith NotFound

183+ | otherwise = respond $ failWith err404

185

184

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

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

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

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

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

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

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

559 r <- rawApplication

558 r <- rawApplication

560 case r of

559 case r of

561− RR (Left err) -> respond $ failWith err

562− RR (Right app) -> app request (respond . succeedWith)

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

561+ Retriable e -> respond $ failWith e

562+ NonRetriable e -> respond $! failFatallyWith 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 $ failWith $ UnsupportedMediaType

602+ Nothing -> return $! failFatallyWith err415

603− Just (Left e) -> return $ failWith $ InvalidBody e

603+ Just (Left e) -> return $! failFatallyWith 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−3

@@ -7,6 +7,8 @@ import qualified Data.Map as M

7import Data.Monoid ((<>))

8import Data.Text (Text)

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

10+import Servant.Server.Internal.ServantErr

11+import Servant.Server.Internal.PathInfo

10import Servant.Server.Internal.RoutingApplication

12import Servant.Server.Internal.RoutingApplication

12type Router = Router' RoutingApplication

14type Router = Router' RoutingApplication

@@ -63,17 +65,24 @@ runRouter (StaticRouter table) request respond =

63 | Just router <- M.lookup first table

65 | Just router <- M.lookup first table

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

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

65 in runRouter router request' respond

67 in runRouter router request' respond

66− _ -> respond $ failWith NotFound

68+ _ -> respond $ failWith err404

67runRouter (DynamicRouter fun) request respond =

69runRouter (DynamicRouter fun) request respond =

68 case pathInfo request of

70 case pathInfo request of

69 first : rest

71 first : rest

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

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

71 in runRouter (fun first) request' respond

73 in runRouter (fun first) request' respond

72− _ -> respond $ failWith NotFound

74+ _ -> respond $ failWith err404

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

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

74runRouter (Choice r1 r2) request respond =

76runRouter (Choice r1 r2) request respond =

75 runRouter r1 request $ \ mResponse1 ->

77 runRouter r1 request $ \ mResponse1 ->

76 if isMismatch mResponse1

78 if isMismatch mResponse1

77 then runRouter r2 request $ \ mResponse2 ->

79 then runRouter r2 request $ \ mResponse2 ->

78− respond (mResponse1 <> mResponse2)

80+ respond (highestPri mResponse1 mResponse2)

79 else respond mResponse1

81 else respond mResponse1

82+ where

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

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

85+ then (Retriable r2)

86+ else (Retriable r1)

87+ highestPri (Retriable _) y = y

88+ highestPri x _ = x

servant-server/src/Servant/Server/Internal/RoutingApplication.hs+38−71

@@ -1,4 +1,5 @@

1{-# LANGUAGE CPP #-}

2+{-# LANGUAGE DeriveFunctor #-}

2{-# LANGUAGE GeneralizedNewtypeDeriving #-}

3{-# LANGUAGE GeneralizedNewtypeDeriving #-}

3{-# LANGUAGE OverloadedStrings #-}

4{-# LANGUAGE OverloadedStrings #-}

4{-# LANGUAGE TypeOperators #-}

5{-# LANGUAGE TypeOperators #-}

@@ -6,21 +7,17 @@ module Servant.Server.Internal.RoutingApplication where

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

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

8import Control.Applicative (Applicative, (<$>))

9import Control.Applicative (Applicative, (<$>))

9−import Data.Monoid (Monoid, mappend, mempty)

10+import Data.Monoid (Monoid, mappend, mempty,

11+ (<>))

10#endif

12#endif

11import Control.Monad.Trans.Except (ExceptT, runExceptT)

13import Control.Monad.Trans.Except (ExceptT, runExceptT)

12import qualified Data.ByteString as B

14import qualified Data.ByteString as B

13import qualified Data.ByteString.Lazy as BL

15import qualified Data.ByteString.Lazy as BL

14import Data.IORef (newIORef, readIORef,

16import Data.IORef (newIORef, readIORef,

15 writeIORef)

17 writeIORef)

16−import Data.Maybe (fromMaybe)

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

18−import Data.String (fromString)

19−import Network.HTTP.Types hiding (Header,

20− ResponseHeaders)

21import Network.Wai (Application, Request,

18import Network.Wai (Application, Request,

22 Response, ResponseReceived,

19 Response, ResponseReceived,

23− requestBody, responseLBS,

20+ requestBody,

24 strictRequestBody)

21 strictRequestBody)

25import Servant.API ((:<|>) (..))

22import Servant.API ((:<|>) (..))

26import Servant.Server.Internal.ServantErr

23import Servant.Server.Internal.ServantErr

@@ -30,39 +27,12 @@ type RoutingApplication =

30 -> (RouteResult Response -> IO ResponseReceived) -> IO ResponseReceived

27 -> (RouteResult Response -> IO ResponseReceived) -> IO ResponseReceived

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

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

33−newtype RouteResult a =

30+data RouteResult a =

34− RR { routeResult :: Either RouteMismatch a }

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

35− deriving (Eq, Show, Functor, Applicative)

32+ -- should only be 404 or 405.

36−

33+ | NonRetriable ServantErr -- ^ Stop trying.

37−-- | If we get a `Right`, it has precedence over everything else.

34+ | HandlerVal a

38−--

35+ deriving (Eq, Show, Read, Functor)

39−-- This in particular means that if we could get several 'Right's,

40−-- only the first we encounter would be taken into account.

41−instance Monoid (RouteResult a) where

42− mempty = RR $ Left mempty

43−

44− RR (Left x) `mappend` RR (Left y) = RR $ Left (x <> y)

45− RR (Left _) `mappend` RR (Right y) = RR $ Right y

46− r `mappend` _ = r

47−

48−-- Note that the ordering of the constructors has great significance! It

49−-- determines the Ord instance and, consequently, the monoid instance.

50−data RouteMismatch =

51− NotFound -- ^ the usual "not found" error

52− | WrongMethod -- ^ a more informative "you just got the HTTP method wrong" error

53− | UnsupportedMediaType -- ^ request body has unsupported media type

54− | InvalidBody String -- ^ an even more informative "your json request body wasn't valid" error

55− | HttpError Status (Maybe BL.ByteString) -- ^ an even even more informative arbitrary HTTP response code error.

56− deriving (Eq, Ord, Show)

57−

58−instance Monoid RouteMismatch where

59− mempty = NotFound

60− -- The following isn't great, since it picks @InvalidBody@ based on

61− -- alphabetical ordering, but any choice would be arbitrary.

62− --

63− -- "As one judge said to the other, 'Be just and if you can't be just, be

64− -- arbitrary'" -- William Burroughs

65− mappend = max

67data ReqBodyState = Uncalled

37data ReqBodyState = Uncalled

68 | Called !B.ByteString

38 | Called !B.ByteString

@@ -91,55 +61,52 @@ toApplication ra request respond = do

91 writeIORef reqBodyRef $ Called bs

61 writeIORef reqBodyRef $ Called bs

92 return B.empty

62 return B.empty

94− ra request{ requestBody = memoReqBody } (routingRespond . routeResult)

64+ ra request{ requestBody = memoReqBody } routingRespond

95 where

65 where

96− routingRespond :: Either RouteMismatch Response -> IO ResponseReceived

66+ routingRespond :: RouteResult Response -> IO ResponseReceived

97− routingRespond (Left NotFound) =

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

98− respond $ responseLBS notFound404 [] "not found"

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

99− routingRespond (Left WrongMethod) =

69+ routingRespond (HandlerVal v) = respond v

100− respond $ responseLBS methodNotAllowed405 [] "method not allowed"

101− routingRespond (Left (InvalidBody err)) =

102− respond $ responseLBS badRequest400 [] $ fromString $ "invalid request body: " ++ err

103− routingRespond (Left UnsupportedMediaType) =

104− respond $ responseLBS unsupportedMediaType415 [] "unsupported media type"

105− routingRespond (Left (HttpError status body)) =

106− respond $ responseLBS status [] $ fromMaybe (BL.fromStrict $ statusMessage status) body

107− routingRespond (Right response) =

108− respond response

109

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

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

111 -> (RouteResult Response -> IO r)

72 -> (RouteResult Response -> IO r)

112 -> (a -> RouteResult Response)

73 -> (a -> RouteResult Response)

113 -> IO r

74 -> IO r

114−runAction action respond k = do

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

115− r <- action

116− go r

117 where

76 where

118− go (RR (Right a)) = do

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

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

79+ go (HandlerVal a) = do

119 e <- runExceptT a

80 e <- runExceptT a

120− respond $ case e of

81+ case e of

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

121− Right x -> k x

83+ Right x -> return $! k x

122− Left err -> succeedWith $ responseServantErr err

123− go (RR (Left err)) = respond $ failWith err

124

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

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

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

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

127

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

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

129−extractL (RR (Right (a :<|> _))) = RR (Right a)

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

130−extractL (RR (Left err)) = RR (Left err)

90+extractL (Retriable x) = Retriable x

91+extractL (NonRetriable x) = NonRetriable x

131

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

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

133−extractR (RR (Right (_ :<|> b))) = RR (Right b)

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

134−extractR (RR (Left err)) = RR (Left err)

95+extractR (Retriable x) = Retriable x

96+extractR (NonRetriable x) = NonRetriable x

97+

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

99+failWith :: ServantErr -> RouteResult a

100+failWith = Retriable

135

101

136−failWith :: RouteMismatch -> RouteResult a

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

137−failWith = RR . Left

103+failFatallyWith :: ServantErr -> RouteResult a

104+failFatallyWith = NonRetriable

138

105

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

139succeedWith :: a -> RouteResult a

107succeedWith :: a -> RouteResult a

140−succeedWith = RR . Right

108+succeedWith = HandlerVal

141

109

142isMismatch :: RouteResult a -> Bool

110isMismatch :: RouteResult a -> Bool

143−isMismatch (RR (Left _)) = True

111+isMismatch (Retriable _) = True

144isMismatch _ = False

112isMismatch _ = False

145−

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

@@ -11,7 +11,7 @@ data ServantErr = ServantErr { errHTTPCode :: Int

11 , errReasonPhrase :: String

12 , errBody :: LBS.ByteString

13 , errHeaders :: [HTTP.Header]

14− } deriving (Show, Eq)

14+ } deriving (Show, Eq, Read)

16responseServantErr :: ServantErr -> Response

17responseServantErr ServantErr{..} = responseLBS status errHeaders errBody

servant-server/test/Servant/Server/ErrorSpec.hs+69−25

@@ -7,9 +7,9 @@ module Servant.Server.ErrorSpec (spec) where

8import Data.Aeson (encode)

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

10−import Control.Monad.Trans.Either (left)

11import Data.Proxy

10import Data.Proxy

12−import Network.HTTP.Types (methodGet, methodPost)

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

12+ methodPost)

13import Test.Hspec

14import Test.Hspec.Wai

@@ -31,8 +31,9 @@ import Servant

32spec :: Spec

33spec = describe "HTTP Errors" $ do

34− errorOrder

34+ errorOrderSpec

35− errorRetry

35+ errorRetrySpec

36+ errorChoiceSpec

37------------------------------------------------------------------------------

38------------------------------------------------------------------------------

38-- * Error Order {{{

39-- * Error Order {{{

@@ -42,24 +43,24 @@ type ErrorOrderApi = "home"

42 :> Capture "t" Int

43 :> Capture "t" Int

43 :> Post '[JSON] Int

44 :> Post '[JSON] Int

46+

45errorOrderApi :: Proxy ErrorOrderApi

47errorOrderApi :: Proxy ErrorOrderApi

46errorOrderApi = Proxy

48errorOrderApi = Proxy

48errorOrderServer :: Server ErrorOrderApi

50errorOrderServer :: Server ErrorOrderApi

49−errorOrderServer = \_ _ -> left err402

51+errorOrderServer = \_ _ -> return 5

51−errorOrder :: Spec

53+errorOrderSpec :: Spec

52−errorOrder = describe "HTTP error order"

54+errorOrderSpec = describe "HTTP error order"

53 $ with (return $ serve errorOrderApi errorOrderServer) $ do

55 $ with (return $ serve errorOrderApi errorOrderServer) $ do

54− let badContentType = ("Content-Type", "text/plain")

56+ let badContentType = (hContentType, "text/plain")

55− badAccept = ("Accept", "text/plain")

57+ badAccept = (hAccept, "text/plain")

56 badMethod = methodGet

58 badMethod = methodGet

57 badUrl = "home/nonexistent"

59 badUrl = "home/nonexistent"

58 badBody = "nonsense"

60 badBody = "nonsense"

59− goodContentType = ("Content-Type", "application/json")

60− goodAccept = ("Accept", "application/json")

61+ goodContentType = (hContentType, "application/json")

61 goodMethod = methodPost

62 goodMethod = methodPost

62− goodUrl = "home/5"

63+ goodUrl = "home/2"

63 goodBody = encode (5 :: Int)

64 goodBody = encode (5 :: Int)

65 it "has 404 as its highest priority error" $ do

66 it "has 404 as its highest priority error" $ do

@@ -82,10 +83,6 @@ errorOrder = describe "HTTP error order"

82 request goodMethod goodUrl [goodContentType, badAccept] goodBody

83 request goodMethod goodUrl [goodContentType, badAccept] goodBody

83 `shouldRespondWith` 406

84 `shouldRespondWith` 406

85− it "returns handler errors as its lower priority errors" $ do

86− request goodMethod goodUrl [goodContentType, goodAccept] goodBody

87− `shouldRespondWith` 402

88−

89-- }}}

86-- }}}

90------------------------------------------------------------------------------

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

91-- * Error Retry {{{

88-- * Error Retry {{{

@@ -95,9 +92,10 @@ type ErrorRetryApi

95 :<|> "a" :> ReqBody '[PlainText] Int :> Post '[JSON] Int -- 1

92 :<|> "a" :> ReqBody '[PlainText] Int :> Post '[JSON] Int -- 1

96 :<|> "a" :> ReqBody '[JSON] Int :> Post '[PlainText] Int -- 2

93 :<|> "a" :> ReqBody '[JSON] Int :> Post '[PlainText] Int -- 2

97 :<|> "a" :> ReqBody '[JSON] String :> Post '[JSON] Int -- 3

94 :<|> "a" :> ReqBody '[JSON] String :> Post '[JSON] Int -- 3

98− :<|> "a" :> ReqBody '[JSON] Int :> Get '[PlainText] Int -- 4

95+ :<|> "a" :> ReqBody '[JSON] Int :> Get '[JSON] Int -- 4

99− :<|> ReqBody '[JSON] Int :> Get '[JSON] Int -- 5

96+ :<|> "a" :> ReqBody '[JSON] Int :> Get '[PlainText] Int -- 5

100 :<|> ReqBody '[JSON] Int :> Get '[JSON] Int -- 6

97 :<|> ReqBody '[JSON] Int :> Get '[JSON] Int -- 6

98+ :<|> ReqBody '[JSON] Int :> Post '[JSON] Int -- 7

101

102errorRetryApi :: Proxy ErrorRetryApi

100errorRetryApi :: Proxy ErrorRetryApi

103errorRetryApi = Proxy

101errorRetryApi = Proxy

@@ -111,19 +109,21 @@ errorRetryServer

111 :<|> (\_ -> return 4)

109 :<|> (\_ -> return 4)

112 :<|> (\_ -> return 5)

110 :<|> (\_ -> return 5)

113 :<|> (\_ -> return 6)

111 :<|> (\_ -> return 6)

112+ :<|> (\_ -> return 7)

114

113

115−errorRetry :: Spec

114+errorRetrySpec :: Spec

116−errorRetry = describe "Handler search"

115+errorRetrySpec = describe "Handler search"

117 $ with (return $ serve errorRetryApi errorRetryServer) $ do

116 $ with (return $ serve errorRetryApi errorRetryServer) $ do

117+

118− let plainCT = ("Content-Type", "text/plain")

118+ let plainCT = (hContentType, "text/plain")

119− plainAccept = ("Accept", "text/plain")

119+ plainAccept = (hAccept, "text/plain")

120− jsonCT = ("Content-Type", "application/json")

120+ jsonCT = (hContentType, "application/json")

121− jsonAccept = ("Accept", "application/json")

121+ jsonAccept = (hAccept, "application/json")

122 jsonBody = encode (1797 :: Int)

123

124 it "should continue when URLs don't match" $ do

125 request methodPost "" [jsonCT, jsonAccept] jsonBody

126− `shouldRespondWith` 201 { matchBody = Just $ encode (5 :: Int) }

126+ `shouldRespondWith` 201 { matchBody = Just $ encode (7 :: Int) }

127

128 it "should continue when methods don't match" $ do

129 request methodGet "a" [jsonCT, jsonAccept] jsonBody

@@ -141,6 +141,50 @@ errorRetry = describe "Handler search"

141 request methodPost "a" [jsonCT, plainAccept] jsonBody

142 `shouldRespondWith` 406

143

144+-- }}}

145+------------------------------------------------------------------------------

146+-- * Error Choice {{{

147+

148+type ErrorChoiceApi

149+ = "path0" :> Get '[JSON] Int -- 0

150+ :<|> "path1" :> Post '[JSON] Int -- 1

151+ :<|> "path2" :> Post '[PlainText] Int -- 2

152+ :<|> "path3" :> ReqBody '[JSON] Int :> Post '[PlainText] Int -- 3

153+ :<|> "path4" :> (ReqBody '[PlainText] Int :> Post '[PlainText] Int -- 4

154+ :<|> ReqBody '[PlainText] Int :> Post '[JSON] Int) -- 5

155+

156+errorChoiceApi :: Proxy ErrorChoiceApi

157+errorChoiceApi = Proxy

158+

159+errorChoiceServer :: Server ErrorChoiceApi

160+errorChoiceServer = return 0

161+ :<|> return 1

162+ :<|> return 2

163+ :<|> (\_ -> return 3)

164+ :<|> (\_ -> return 4)

165+ :<|> (\_ -> return 5)

166+

167+

168+errorChoiceSpec :: Spec

169+errorChoiceSpec = describe "Multiple handlers return errors"

170+ $ with (return $ serve errorChoiceApi errorChoiceServer) $ do

171+

172+ it "should respond with 404 if no path matches" $ do

173+ request methodGet "" [] "" `shouldRespondWith` 404

174+

175+ it "should respond with 405 if a path but not method matches" $ do

176+ request methodGet "path2" [] "" `shouldRespondWith` 405

177+

178+ it "should respond with the corresponding error if path and method match" $ do

179+ request methodPost "path3" [(hContentType, "text/plain;charset=utf-8")] ""

180+ `shouldRespondWith` 415

181+ request methodPost "path3" [(hContentType, "application/json")] ""

182+ `shouldRespondWith` 400

183+ request methodPost "path4" [(hContentType, "text/plain;charset=utf-8"),

184+ (hAccept, "application/json")] ""

185+ `shouldRespondWith` 406

186+

187+

144-- }}}

188-- }}}

145------------------------------------------------------------------------------

189------------------------------------------------------------------------------

146-- * Instances {{{

190-- * Instances {{{

servant-server/test/Servant/ServerSpec.hs+10−57

@@ -17,7 +17,6 @@ import Control.Monad.Trans.Except (ExceptT, throwE)

17import Data.Aeson (FromJSON, ToJSON, decode', encode)

18import Data.ByteString.Conversion ()

19import Data.Char (toUpper)

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

21import Data.Proxy (Proxy (Proxy))

20import Data.Proxy (Proxy (Proxy))

22import Data.String (fromString)

21import Data.String (fromString)

23import Data.String.Conversions (cs)

22import Data.String.Conversions (cs)

@@ -26,8 +25,7 @@ import GHC.Generics (Generic)

26import Network.HTTP.Types (hAccept, hContentType,

25import Network.HTTP.Types (hAccept, hContentType,

27 methodDelete, methodGet, methodHead,

26 methodDelete, methodGet, methodHead,

28 methodPatch, methodPost, methodPut,

27 methodPatch, methodPost, methodPut,

29− ok200, parseQuery, status409,

28+ ok200, parseQuery, Status(..))

30− Status(..))

31import Network.Wai (Application, Request, pathInfo,

29import Network.Wai (Application, Request, pathInfo,

32 queryString, rawQueryString,

30 queryString, rawQueryString,

33 responseLBS, responseBuilder)

31 responseLBS, responseBuilder)

@@ -99,7 +97,6 @@ spec = do

99 rawSpec

97 rawSpec

100 unionSpec

98 unionSpec

101 prioErrorsSpec

99 prioErrorsSpec

102− errorsSpec

103 routerSpec

100 routerSpec

104 responseHeadersSpec

101 responseHeadersSpec

105 miscReqCombinatorsSpec

102 miscReqCombinatorsSpec

@@ -158,9 +155,9 @@ getSpec = do

158 it "returns 204 if the type is '()'" $ do

155 it "returns 204 if the type is '()'" $ do

159 get "/empty" `shouldRespondWith` ""{ matchStatus = 204 }

156 get "/empty" `shouldRespondWith` ""{ matchStatus = 204 }

160

157

161− it "returns 415 if the Accept header is not supported" $ do

158+ it "returns 406 if the Accept header is not supported" $ do

162 Test.Hspec.Wai.request methodGet "" [(hAccept, "crazy/mime")] ""

159 Test.Hspec.Wai.request methodGet "" [(hAccept, "crazy/mime")] ""

163− `shouldRespondWith` 415

160+ `shouldRespondWith` 406

164

161

165

162

166headSpec :: Spec

163headSpec :: Spec

@@ -186,9 +183,9 @@ headSpec = do

186 response <- Test.Hspec.Wai.request methodHead "/empty" [] ""

183 response <- Test.Hspec.Wai.request methodHead "/empty" [] ""

187 return response `shouldRespondWith` ""{ matchStatus = 204 }

184 return response `shouldRespondWith` ""{ matchStatus = 204 }

188

185

189− it "returns 415 if the Accept header is not supported" $ do

186+ it "returns 406 if the Accept header is not supported" $ do

190 Test.Hspec.Wai.request methodHead "" [(hAccept, "crazy/mime")] ""

187 Test.Hspec.Wai.request methodHead "" [(hAccept, "crazy/mime")] ""

191− `shouldRespondWith` 415

188+ `shouldRespondWith` 406

192

189

193

190

194type QueryParamApi = QueryParam "name" String :> Get '[JSON] Person

191type QueryParamApi = QueryParam "name" String :> Get '[JSON] Person

@@ -311,7 +308,7 @@ postSpec = do

311 it "returns 204 if the type is '()'" $ do

308 it "returns 204 if the type is '()'" $ do

312 post' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 }

309 post' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 }

313

310

314− it "responds with 415 if the requested media type is unsupported" $ do

311+ it "responds with 415 if the request body media type is unsupported" $ do

315 let post'' x = Test.Hspec.Wai.request methodPost x [(hContentType

312 let post'' x = Test.Hspec.Wai.request methodPost x [(hContentType

316 , "application/nonsense")]

313 , "application/nonsense")]

317 post'' "/" "anything at all" `shouldRespondWith` 415

314 post'' "/" "anything at all" `shouldRespondWith` 415

@@ -353,7 +350,7 @@ putSpec = do

353 it "returns 204 if the type is '()'" $ do

350 it "returns 204 if the type is '()'" $ do

354 put' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 }

351 put' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 }

355

352

356− it "responds with 415 if the requested media type is unsupported" $ do

353+ it "responds with 415 if the request body media type is unsupported" $ do

357 let put'' x = Test.Hspec.Wai.request methodPut x [(hContentType

354 let put'' x = Test.Hspec.Wai.request methodPut x [(hContentType

358 , "application/nonsense")]

355 , "application/nonsense")]

359 put'' "/" "anything at all" `shouldRespondWith` 415

356 put'' "/" "anything at all" `shouldRespondWith` 415

@@ -395,7 +392,7 @@ patchSpec = do

395 it "returns 204 if the type is '()'" $ do

392 it "returns 204 if the type is '()'" $ do

396 patch' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 }

393 patch' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 }

397

394

398− it "responds with 415 if the requested media type is unsupported" $ do

395+ it "responds with 415 if the request body media type is unsupported" $ do

399 let patch'' x = Test.Hspec.Wai.request methodPatch x [(hContentType

396 let patch'' x = Test.Hspec.Wai.request methodPatch x [(hContentType

400 , "application/nonsense")]

397 , "application/nonsense")]

401 patch'' "/" "anything at all" `shouldRespondWith` 415

398 patch'' "/" "anything at all" `shouldRespondWith` 415

@@ -524,10 +521,10 @@ responseHeadersSpec = describe "ResponseHeaders" $ do

524 Test.Hspec.Wai.request method "blahblah" [] ""

521 Test.Hspec.Wai.request method "blahblah" [] ""

525 `shouldRespondWith` 404

522 `shouldRespondWith` 404

526

523

527− it "returns 415 if the Accept header is not supported" $

524+ it "returns 406 if the Accept header is not supported" $

528 forM_ methods $ \(method,_) ->

525 forM_ methods $ \(method,_) ->

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

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

530− `shouldRespondWith` 415

527+ `shouldRespondWith` 406

531

528

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

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

533

530

@@ -578,50 +575,6 @@ prioErrorsSpec = describe "PrioErrors" $ do

578 check put' "/bar" vjson 404

575 check put' "/bar" vjson 404

579 check put' "/foo" vjson 405

576 check put' "/foo" vjson 405

580

577

581−-- | Test server error functionality.

582−errorsSpec :: Spec

583−errorsSpec = do

584− let he = HttpError status409 (Just "A custom error")

585− let ib = InvalidBody "The body is invalid"

586− let wm = WrongMethod

587− let nf = NotFound

588−

589− describe "Servant.Server.Internal.RouteMismatch" $ do

590− it "HttpError > *" $ do

591− ib <> he `shouldBe` he

592− wm <> he `shouldBe` he

593− nf <> he `shouldBe` he

594−

595− he <> ib `shouldBe` he

596− he <> wm `shouldBe` he

597− he <> nf `shouldBe` he

598−

599− it "HE > InvalidBody > (WM,NF)" $ do

600− he <> ib `shouldBe` he

601− wm <> ib `shouldBe` ib

602− nf <> ib `shouldBe` ib

603−

604− ib <> he `shouldBe` he

605− ib <> wm `shouldBe` ib

606− ib <> nf `shouldBe` ib

607−

608− it "HE > IB > WrongMethod > NF" $ do

609− he <> wm `shouldBe` he

610− ib <> wm `shouldBe` ib

611− nf <> wm `shouldBe` wm

612−

613− wm <> he `shouldBe` he

614− wm <> ib `shouldBe` ib

615− wm <> nf `shouldBe` wm

616−

617− it "* > NotFound" $ do

618− he <> nf `shouldBe` he

619− ib <> nf `shouldBe` ib

620− wm <> nf `shouldBe` wm

621−

622− nf <> he `shouldBe` he

623− nf <> ib `shouldBe` ib

624− nf <> wm `shouldBe` wm

625

578

626routerSpec :: Spec

579routerSpec :: Spec

627routerSpec = do

580routerSpec = do

servant/test/Servant/API/ContentTypesSpec.hs+15

@@ -3,6 +3,7 @@

3{-# LANGUAGE DeriveGeneric #-}

4{-# LANGUAGE MultiParamTypeClasses #-}

5{-# LANGUAGE OverloadedStrings #-}

6+{-# LANGUAGE PolyKinds #-}

6{-# OPTIONS_GHC -fno-warn-orphans #-}

7{-# OPTIONS_GHC -fno-warn-orphans #-}

7module Servant.API.ContentTypesSpec where

8module Servant.API.ContentTypesSpec where

@@ -34,6 +35,20 @@ import Servant.API.ContentTypes

34spec :: Spec

35spec :: Spec

35spec = describe "Servant.API.ContentTypes" $ do

36spec = describe "Servant.API.ContentTypes" $ do

38+ describe "handleAcceptH" $ do

39+ let p = Proxy :: Proxy '[PlainText]

40+

41+ it "matches any charset if none were provided" $ do

42+ let without = handleAcceptH p (AcceptHeader "text/plain")

43+ with = handleAcceptH p (AcceptHeader "text/plain;charset=utf-8")

44+ wisdom = "ubi sub ubi" :: String

45+ without wisdom `shouldBe` with wisdom

46+

47+ it "does not match non utf-8 charsets" $ do

48+ let badCharset = handleAcceptH p (AcceptHeader "text/plain;charset=whoknows")

49+ s = "cheese" :: String

50+ badCharset s `shouldBe` Nothing

51+

37 describe "The JSON Content-Type type" $ do

52 describe "The JSON Content-Type type" $ do

38 let p = Proxy :: Proxy JSON

53 let p = Proxy :: Proxy JSON