eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

Refactor RouteResult.

Browse source 
Fix rerouting tests
        Fix 405 > 404 issue with Capture.
        Remove ServantErrWithPriority and Monoid instance
        More tests
        Update auth-combinator for routing changes
This commit is contained in:
Julian K. Arni 2015-09-09 23:49:19 -07:00
parent 153de01a62
commit a3b5652ab9
9 changed files with 165 additions and 176 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

5
servant-examples/auth-combinator/auth-combinator.hs
View file

@ -5,6 +5,7 @@
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
import Data.Aeson import Data.Aeson
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import Data.Text (Text) import Data.Text (Text)
@ -31,12 +32,12 @@ instance HasServer rest => HasServer (AuthProtected :> rest) where
route Proxy a = WithRequest $ \ request -> route Proxy a = WithRequest $ \ request ->
route (Proxy :: Proxy rest) $ do route (Proxy :: Proxy rest) $ do
case lookup "Cookie" (requestHeaders request) of case lookup "Cookie" (requestHeaders request) of
Nothing -> return $ failWith $ HttpError status401 (Just "Missing auth header.") Nothing -> return $! failFatallyWith err401 { errBody = "Missing auth header" }
Just v -> do Just v -> do
authGranted <- isGoodCookie v authGranted <- isGoodCookie v
if authGranted if authGranted
then a then a
else return $ failWith $ HttpError status403 (Just "Invalid cookie.") else return $! failFatallyWith err403 { errBody = "Invalid cookie" }
type PrivateAPI = Get '[JSON] [PrivateData] type PrivateAPI = Get '[JSON] [PrivateData]

2
servant-server/src/Servant/Server.hs
View file

@ -103,7 +103,7 @@ import Servant.Server.Internal.Enter
-- > main = Network.Wai.Handler.Warp.run 8080 app -- > main = Network.Wai.Handler.Warp.run 8080 app
-- --
serve :: HasServer layout => Proxy layout -> Server layout -> Application serve :: HasServer layout => Proxy layout -> Server layout -> Application
serve p server = toApplication (runRouter (route p (return (RR (Right server))))) serve p server = toApplication (runRouter (route p (return (HandlerVal server))))
-- Documentation -- Documentation

32
servant-server/src/Servant/Server/Internal.hs
View file

@ -113,11 +113,10 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout)
a -> ServerT sublayout m a -> ServerT sublayout m
route Proxy subserver = route Proxy subserver =
DynamicRouter $ \ first -> DynamicRouter $ \ first -> case captured captureProxy first of
route (Proxy :: Proxy sublayout) Nothing -> LeafRouter (\_ r -> r $ failWith err404)
(case captured captureProxy first of Just v -> route (Proxy :: Proxy sublayout) (feedTo subserver v)
Nothing -> return $ failWith NotFound
Just v -> feedTo subserver v)
where captureProxy = Proxy :: Proxy (Capture capture a) where captureProxy = Proxy :: Proxy (Capture capture a)
allowedMethodHead :: Method -> Request -> Bool allowedMethodHead :: Method -> Request -> Bool
@ -131,7 +130,7 @@ processMethodRouter :: forall a. ConvertibleStrings a B.ByteString
-> Maybe [(HeaderName, B.ByteString)] -> Maybe [(HeaderName, B.ByteString)]
-> Request -> RouteResult Response -> Request -> RouteResult Response
processMethodRouter handleA status method headers request = case handleA of processMethodRouter handleA status method headers request = case handleA of
Nothing -> failWith UnsupportedMediaType Nothing -> failFatallyWith err406
Just (contentT, body) -> succeedWith $ responseLBS status hdrs bdy Just (contentT, body) -> succeedWith $ responseLBS status hdrs bdy
where where
bdy = if allowedMethodHead method request then "" else body bdy = if allowedMethodHead method request then "" else body
@ -150,8 +149,8 @@ methodRouter method proxy status action = LeafRouter route'
handleA = handleAcceptH proxy (AcceptHeader accH) output handleA = handleAcceptH proxy (AcceptHeader accH) output
processMethodRouter handleA status method Nothing request processMethodRouter handleA status method Nothing request
| pathIsEmpty request && requestMethod request /= method = | pathIsEmpty request && requestMethod request /= method =
respond $ failWith WrongMethod respond $ failWith err405
| otherwise = respond $ failWith NotFound | otherwise = respond $ failWith err404
methodRouterHeaders :: (GetHeaders (Headers h v), AllCTRender ctypes v) methodRouterHeaders :: (GetHeaders (Headers h v), AllCTRender ctypes v)
=> Method -> Proxy ctypes -> Status => Method -> Proxy ctypes -> Status
@ -167,8 +166,8 @@ methodRouterHeaders method proxy status action = LeafRouter route'
handleA = handleAcceptH proxy (AcceptHeader accH) (getResponse output) handleA = handleAcceptH proxy (AcceptHeader accH) (getResponse output)
processMethodRouter handleA status method (Just headers) request processMethodRouter handleA status method (Just headers) request
| pathIsEmpty request && requestMethod request /= method = | pathIsEmpty request && requestMethod request /= method =
respond $ failWith WrongMethod respond $ failWith err405
| otherwise = respond $ failWith NotFound | otherwise = respond $ failWith err404
methodRouterEmpty :: Method methodRouterEmpty :: Method
-> IO (RouteResult (ExceptT ServantErr IO ())) -> IO (RouteResult (ExceptT ServantErr IO ()))
@ -180,8 +179,8 @@ methodRouterEmpty method action = LeafRouter route'
runAction action respond $ \ () -> runAction action respond $ \ () ->
succeedWith $ responseLBS noContent204 [] "" succeedWith $ responseLBS noContent204 [] ""
| pathIsEmpty request && requestMethod request /= method = | pathIsEmpty request && requestMethod request /= method =
respond $ failWith WrongMethod respond $ failWith err405
| otherwise = respond $ failWith NotFound | otherwise = respond $ failWith err404
-- | If you have a 'Delete' endpoint in your API, -- | If you have a 'Delete' endpoint in your API,
-- the handler for this endpoint is meant to delete -- the handler for this endpoint is meant to delete
@ -558,8 +557,9 @@ instance HasServer Raw where
route Proxy rawApplication = LeafRouter $ \ request respond -> do route Proxy rawApplication = LeafRouter $ \ request respond -> do
r <- rawApplication r <- rawApplication
case r of case r of
RR (Left err) -> respond $ failWith err HandlerVal app -> app request (respond . succeedWith)
RR (Right app) -> app request (respond . succeedWith) Retriable e -> respond $ failWith e
NonRetriable e -> respond $! failFatallyWith e
-- | If you use 'ReqBody' in one of the endpoints for your API, -- | If you use 'ReqBody' in one of the endpoints for your API,
-- this automatically requires your server-side handler to be a function -- this automatically requires your server-side handler to be a function
@ -599,8 +599,8 @@ instance ( AllCTUnrender list a, HasServer sublayout
mrqbody <- handleCTypeH (Proxy :: Proxy list) (cs contentTypeH) mrqbody <- handleCTypeH (Proxy :: Proxy list) (cs contentTypeH)
<$> lazyRequestBody request <$> lazyRequestBody request
case mrqbody of case mrqbody of
Nothing -> return $ failWith $ UnsupportedMediaType Nothing -> return $! failFatallyWith err415
Just (Left e) -> return $ failWith $ InvalidBody e Just (Left e) -> return $! failFatallyWith err400 { errBody = cs e }
Just (Right v) -> feedTo subserver v Just (Right v) -> feedTo subserver v
-- | Make sure the incoming request starts with @"/path"@, strip it and -- | Make sure the incoming request starts with @"/path"@, strip it and

15
servant-server/src/Servant/Server/Internal/Router.hs
View file

@ -7,6 +7,8 @@ import qualified Data.Map as M
import Data.Monoid ((<>)) import Data.Monoid ((<>))
import Data.Text (Text) import Data.Text (Text)
import Network.Wai (Request, Response, pathInfo) import Network.Wai (Request, Response, pathInfo)
import Servant.Server.Internal.ServantErr
import Servant.Server.Internal.PathInfo
import Servant.Server.Internal.RoutingApplication import Servant.Server.Internal.RoutingApplication
type Router = Router' RoutingApplication type Router = Router' RoutingApplication
@ -63,17 +65,24 @@ runRouter (StaticRouter table) request respond =
| Just router <- M.lookup first table | Just router <- M.lookup first table
-> let request' = request { pathInfo = rest } -> let request' = request { pathInfo = rest }
in runRouter router request' respond in runRouter router request' respond
_ -> respond $ failWith NotFound _ -> respond $ failWith err404
runRouter (DynamicRouter fun) request respond = runRouter (DynamicRouter fun) request respond =
case pathInfo request of case pathInfo request of
first : rest first : rest
-> let request' = request { pathInfo = rest } -> let request' = request { pathInfo = rest }
in runRouter (fun first) request' respond in runRouter (fun first) request' respond
_ -> respond $ failWith NotFound _ -> respond $ failWith err404
runRouter (LeafRouter app) request respond = app request respond runRouter (LeafRouter app) request respond = app request respond
runRouter (Choice r1 r2) request respond = runRouter (Choice r1 r2) request respond =
runRouter r1 request $ \ mResponse1 -> runRouter r1 request $ \ mResponse1 ->
if isMismatch mResponse1 if isMismatch mResponse1
then runRouter r2 request $ \ mResponse2 -> then runRouter r2 request $ \ mResponse2 ->
respond (mResponse1 <> mResponse2) respond (highestPri mResponse1 mResponse2)
else respond mResponse1 else respond mResponse1
where
highestPri (Retriable r1) (Retriable r2) =
if errHTTPCode r1 == 404 && errHTTPCode r2 /= 404
then (Retriable r2)
else (Retriable r1)
highestPri (Retriable _) y = y
highestPri x _ = x

109
servant-server/src/Servant/Server/Internal/RoutingApplication.hs
View file

@ -1,4 +1,5 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
@ -6,21 +7,17 @@ module Servant.Server.Internal.RoutingApplication where
#if !MIN_VERSION_base(4,8,0) #if !MIN_VERSION_base(4,8,0)
import Control.Applicative (Applicative, (<$>)) import Control.Applicative (Applicative, (<$>))
import Data.Monoid (Monoid, mappend, mempty) import Data.Monoid (Monoid, mappend, mempty,
(<>))
#endif #endif
import Control.Monad.Trans.Except (ExceptT, runExceptT) import Control.Monad.Trans.Except (ExceptT, runExceptT)
import qualified Data.ByteString as B import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy as BL
import Data.IORef (newIORef, readIORef, import Data.IORef (newIORef, readIORef,
writeIORef) writeIORef)
import Data.Maybe (fromMaybe)
import Data.Monoid ((<>))
import Data.String (fromString)
import Network.HTTP.Types hiding (Header,
ResponseHeaders)
import Network.Wai (Application, Request, import Network.Wai (Application, Request,
Response, ResponseReceived, Response, ResponseReceived,
requestBody, responseLBS, requestBody,
strictRequestBody) strictRequestBody)
import Servant.API ((:<|>) (..)) import Servant.API ((:<|>) (..))
import Servant.Server.Internal.ServantErr import Servant.Server.Internal.ServantErr
@ -30,39 +27,12 @@ type RoutingApplication =
-> (RouteResult Response -> IO ResponseReceived) -> IO ResponseReceived -> (RouteResult Response -> IO ResponseReceived) -> IO ResponseReceived
-- | A wrapper around @'Either' 'RouteMismatch' a@. -- | A wrapper around @'Either' 'RouteMismatch' a@.
newtype RouteResult a = data RouteResult a =
RR { routeResult :: Either RouteMismatch a } Retriable ServantErr -- ^ Keep trying other paths. The @ServantErr@
deriving (Eq, Show, Functor, Applicative) -- should only be 404 or 405.
| NonRetriable ServantErr -- ^ Stop trying.
-- | If we get a `Right`, it has precedence over everything else. | HandlerVal a
-- deriving (Eq, Show, Read, Functor)
-- This in particular means that if we could get several 'Right's,
-- only the first we encounter would be taken into account.
instance Monoid (RouteResult a) where
mempty = RR $ Left mempty
RR (Left x) `mappend` RR (Left y) = RR $ Left (x <> y)
RR (Left _) `mappend` RR (Right y) = RR $ Right y
r `mappend` _ = r
-- Note that the ordering of the constructors has great significance! It
-- determines the Ord instance and, consequently, the monoid instance.
data RouteMismatch =
NotFound -- ^ the usual "not found" error
| WrongMethod -- ^ a more informative "you just got the HTTP method wrong" error
| UnsupportedMediaType -- ^ request body has unsupported media type
| InvalidBody String -- ^ an even more informative "your json request body wasn't valid" error
| HttpError Status (Maybe BL.ByteString) -- ^ an even even more informative arbitrary HTTP response code error.
deriving (Eq, Ord, Show)
instance Monoid RouteMismatch where
mempty = NotFound
-- The following isn't great, since it picks @InvalidBody@ based on
-- alphabetical ordering, but any choice would be arbitrary.
--
-- "As one judge said to the other, 'Be just and if you can't be just, be
-- arbitrary'" -- William Burroughs
mappend = max
data ReqBodyState = Uncalled data ReqBodyState = Uncalled
| Called !B.ByteString | Called !B.ByteString
@ -91,55 +61,52 @@ toApplication ra request respond = do
writeIORef reqBodyRef $ Called bs writeIORef reqBodyRef $ Called bs
return B.empty return B.empty
ra request{ requestBody = memoReqBody } (routingRespond . routeResult) ra request{ requestBody = memoReqBody } routingRespond
where where
routingRespond :: Either RouteMismatch Response -> IO ResponseReceived routingRespond :: RouteResult Response -> IO ResponseReceived
routingRespond (Left NotFound) = routingRespond (Retriable err) = respond $! responseServantErr err
respond $ responseLBS notFound404 [] "not found" routingRespond (NonRetriable err) = respond $! responseServantErr err
routingRespond (Left WrongMethod) = routingRespond (HandlerVal v) = respond v
respond $ responseLBS methodNotAllowed405 [] "method not allowed"
routingRespond (Left (InvalidBody err)) =
respond $ responseLBS badRequest400 [] $ fromString $ "invalid request body: " ++ err
routingRespond (Left UnsupportedMediaType) =
respond $ responseLBS unsupportedMediaType415 [] "unsupported media type"
routingRespond (Left (HttpError status body)) =
respond $ responseLBS status [] $ fromMaybe (BL.fromStrict $ statusMessage status) body
routingRespond (Right response) =
respond response
runAction :: IO (RouteResult (ExceptT ServantErr IO a)) runAction :: IO (RouteResult (ExceptT ServantErr IO a))
-> (RouteResult Response -> IO r) -> (RouteResult Response -> IO r)
-> (a -> RouteResult Response) -> (a -> RouteResult Response)
-> IO r -> IO r
runAction action respond k = do runAction action respond k = action >>= go >>= respond
r <- action
go r
where where
go (RR (Right a)) = do go (Retriable e) = return $! Retriable e
go (NonRetriable e) = return . succeedWith $! responseServantErr e
go (HandlerVal a) = do
e <- runExceptT a e <- runExceptT a
respond $ case e of case e of
Right x -> k x Left err -> return . succeedWith $! responseServantErr err
Left err -> succeedWith $ responseServantErr err Right x -> return $! k x
go (RR (Left err)) = respond $ failWith err
feedTo :: IO (RouteResult (a -> b)) -> a -> IO (RouteResult b) feedTo :: IO (RouteResult (a -> b)) -> a -> IO (RouteResult b)
feedTo f x = (($ x) <$>) <$> f feedTo f x = (($ x) <$>) <$> f
extractL :: RouteResult (a :<|> b) -> RouteResult a extractL :: RouteResult (a :<|> b) -> RouteResult a
extractL (RR (Right (a :<|> _))) = RR (Right a) extractL (HandlerVal (a :<|> _)) = HandlerVal a
extractL (RR (Left err)) = RR (Left err) extractL (Retriable x) = Retriable x
extractL (NonRetriable x) = NonRetriable x
extractR :: RouteResult (a :<|> b) -> RouteResult b extractR :: RouteResult (a :<|> b) -> RouteResult b
extractR (RR (Right (_ :<|> b))) = RR (Right b) extractR (HandlerVal (_ :<|> b)) = HandlerVal b
extractR (RR (Left err)) = RR (Left err) extractR (Retriable x) = Retriable x
extractR (NonRetriable x) = NonRetriable x
failWith :: RouteMismatch -> RouteResult a -- | Fail with a @ServantErr@, but keep trying other paths and.
failWith = RR . Left failWith :: ServantErr -> RouteResult a
failWith = Retriable
-- | Fail with immediately @ServantErr@.
failFatallyWith :: ServantErr -> RouteResult a
failFatallyWith = NonRetriable
-- | Return a value, and don't try other paths.
succeedWith :: a -> RouteResult a succeedWith :: a -> RouteResult a
succeedWith = RR . Right succeedWith = HandlerVal
isMismatch :: RouteResult a -> Bool isMismatch :: RouteResult a -> Bool
isMismatch (RR (Left _)) = True isMismatch (Retriable _) = True
isMismatch _ = False isMismatch _ = False

2
servant-server/src/Servant/Server/Internal/ServantErr.hs
View file

@ -11,7 +11,7 @@ data ServantErr = ServantErr { errHTTPCode :: Int
, errReasonPhrase :: String , errReasonPhrase :: String
, errBody :: LBS.ByteString , errBody :: LBS.ByteString
, errHeaders :: [HTTP.Header] , errHeaders :: [HTTP.Header]
} deriving (Show, Eq) } deriving (Show, Eq, Read)
responseServantErr :: ServantErr -> Response responseServantErr :: ServantErr -> Response
responseServantErr ServantErr{..} = responseLBS status errHeaders errBody responseServantErr ServantErr{..} = responseLBS status errHeaders errBody

94
servant-server/test/Servant/Server/ErrorSpec.hs
View file

@ -7,9 +7,9 @@ module Servant.Server.ErrorSpec (spec) where
import Data.Aeson (encode) import Data.Aeson (encode)
import qualified Data.ByteString.Lazy.Char8 as BC import qualified Data.ByteString.Lazy.Char8 as BC
import Control.Monad.Trans.Either (left)
import Data.Proxy import Data.Proxy
import Network.HTTP.Types (methodGet, methodPost) import Network.HTTP.Types (hAccept, hContentType, methodGet,
methodPost)
import Test.Hspec import Test.Hspec
import Test.Hspec.Wai import Test.Hspec.Wai
@ -31,8 +31,9 @@ import Servant
spec :: Spec spec :: Spec
spec = describe "HTTP Errors" $ do spec = describe "HTTP Errors" $ do
errorOrder errorOrderSpec
errorRetry errorRetrySpec
errorChoiceSpec
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
-- * Error Order {{{ -- * Error Order {{{
@ -42,24 +43,24 @@ type ErrorOrderApi = "home"
:> Capture "t" Int :> Capture "t" Int
:> Post '[JSON] Int :> Post '[JSON] Int
errorOrderApi :: Proxy ErrorOrderApi errorOrderApi :: Proxy ErrorOrderApi
errorOrderApi = Proxy errorOrderApi = Proxy
errorOrderServer :: Server ErrorOrderApi errorOrderServer :: Server ErrorOrderApi
errorOrderServer = \_ _ -> left err402 errorOrderServer = \_ _ -> return 5
errorOrder :: Spec errorOrderSpec :: Spec
errorOrder = describe "HTTP error order" errorOrderSpec = describe "HTTP error order"
$ with (return $ serve errorOrderApi errorOrderServer) $ do $ with (return $ serve errorOrderApi errorOrderServer) $ do
let badContentType = ("Content-Type", "text/plain") let badContentType = (hContentType, "text/plain")
badAccept = ("Accept", "text/plain") badAccept = (hAccept, "text/plain")
badMethod = methodGet badMethod = methodGet
badUrl = "home/nonexistent" badUrl = "home/nonexistent"
badBody = "nonsense" badBody = "nonsense"
goodContentType = ("Content-Type", "application/json") goodContentType = (hContentType, "application/json")
goodAccept = ("Accept", "application/json")
goodMethod = methodPost goodMethod = methodPost
goodUrl = "home/5" goodUrl = "home/2"
goodBody = encode (5 :: Int) goodBody = encode (5 :: Int)
it "has 404 as its highest priority error" $ do it "has 404 as its highest priority error" $ do
@ -82,10 +83,6 @@ errorOrder = describe "HTTP error order"
request goodMethod goodUrl [goodContentType, badAccept] goodBody request goodMethod goodUrl [goodContentType, badAccept] goodBody
`shouldRespondWith` 406 `shouldRespondWith` 406
it "returns handler errors as its lower priority errors" $ do
request goodMethod goodUrl [goodContentType, goodAccept] goodBody
`shouldRespondWith` 402
-- }}} -- }}}
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
-- * Error Retry {{{ -- * Error Retry {{{
@ -95,9 +92,10 @@ type ErrorRetryApi
:<|> "a" :> ReqBody '[PlainText] Int :> Post '[JSON] Int -- 1 :<|> "a" :> ReqBody '[PlainText] Int :> Post '[JSON] Int -- 1
:<|> "a" :> ReqBody '[JSON] Int :> Post '[PlainText] Int -- 2 :<|> "a" :> ReqBody '[JSON] Int :> Post '[PlainText] Int -- 2
:<|> "a" :> ReqBody '[JSON] String :> Post '[JSON] Int -- 3 :<|> "a" :> ReqBody '[JSON] String :> Post '[JSON] Int -- 3
:<|> "a" :> ReqBody '[JSON] Int :> Get '[PlainText] Int -- 4 :<|> "a" :> ReqBody '[JSON] Int :> Get '[JSON] Int -- 4
:<|> ReqBody '[JSON] Int :> Get '[JSON] Int -- 5 :<|> "a" :> ReqBody '[JSON] Int :> Get '[PlainText] Int -- 5
:<|> ReqBody '[JSON] Int :> Get '[JSON] Int -- 6 :<|> ReqBody '[JSON] Int :> Get '[JSON] Int -- 6
:<|> ReqBody '[JSON] Int :> Post '[JSON] Int -- 7
errorRetryApi :: Proxy ErrorRetryApi errorRetryApi :: Proxy ErrorRetryApi
errorRetryApi = Proxy errorRetryApi = Proxy
@ -111,19 +109,21 @@ errorRetryServer
:<|> (\_ -> return 4) :<|> (\_ -> return 4)
:<|> (\_ -> return 5) :<|> (\_ -> return 5)
:<|> (\_ -> return 6) :<|> (\_ -> return 6)
:<|> (\_ -> return 7)
errorRetry :: Spec errorRetrySpec :: Spec
errorRetry = describe "Handler search" errorRetrySpec = describe "Handler search"
$ with (return $ serve errorRetryApi errorRetryServer) $ do $ with (return $ serve errorRetryApi errorRetryServer) $ do
let plainCT = ("Content-Type", "text/plain")
plainAccept = ("Accept", "text/plain") let plainCT = (hContentType, "text/plain")
jsonCT = ("Content-Type", "application/json") plainAccept = (hAccept, "text/plain")
jsonAccept = ("Accept", "application/json") jsonCT = (hContentType, "application/json")
jsonAccept = (hAccept, "application/json")
jsonBody = encode (1797 :: Int) jsonBody = encode (1797 :: Int)
it "should continue when URLs don't match" $ do it "should continue when URLs don't match" $ do
request methodPost "" [jsonCT, jsonAccept] jsonBody request methodPost "" [jsonCT, jsonAccept] jsonBody
`shouldRespondWith` 201 { matchBody = Just $ encode (5 :: Int) } `shouldRespondWith` 201 { matchBody = Just $ encode (7 :: Int) }
it "should continue when methods don't match" $ do it "should continue when methods don't match" $ do
request methodGet "a" [jsonCT, jsonAccept] jsonBody request methodGet "a" [jsonCT, jsonAccept] jsonBody
@ -141,6 +141,50 @@ errorRetry = describe "Handler search"
request methodPost "a" [jsonCT, plainAccept] jsonBody request methodPost "a" [jsonCT, plainAccept] jsonBody
`shouldRespondWith` 406 `shouldRespondWith` 406
-- }}}
------------------------------------------------------------------------------
-- * Error Choice {{{
type ErrorChoiceApi
= "path0" :> Get '[JSON] Int -- 0
:<|> "path1" :> Post '[JSON] Int -- 1
:<|> "path2" :> Post '[PlainText] Int -- 2
:<|> "path3" :> ReqBody '[JSON] Int :> Post '[PlainText] Int -- 3
:<|> "path4" :> (ReqBody '[PlainText] Int :> Post '[PlainText] Int -- 4
:<|> ReqBody '[PlainText] Int :> Post '[JSON] Int) -- 5
errorChoiceApi :: Proxy ErrorChoiceApi
errorChoiceApi = Proxy
errorChoiceServer :: Server ErrorChoiceApi
errorChoiceServer = return 0
:<|> return 1
:<|> return 2
:<|> (\_ -> return 3)
:<|> (\_ -> return 4)
:<|> (\_ -> return 5)
errorChoiceSpec :: Spec
errorChoiceSpec = describe "Multiple handlers return errors"
$ with (return $ serve errorChoiceApi errorChoiceServer) $ do
it "should respond with 404 if no path matches" $ do
request methodGet "" [] "" `shouldRespondWith` 404
it "should respond with 405 if a path but not method matches" $ do
request methodGet "path2" [] "" `shouldRespondWith` 405
it "should respond with the corresponding error if path and method match" $ do
request methodPost "path3" [(hContentType, "text/plain;charset=utf-8")] ""
`shouldRespondWith` 415
request methodPost "path3" [(hContentType, "application/json")] ""
`shouldRespondWith` 400
request methodPost "path4" [(hContentType, "text/plain;charset=utf-8"),
(hAccept, "application/json")] ""
`shouldRespondWith` 406
-- }}} -- }}}
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
-- * Instances {{{ -- * Instances {{{

67
servant-server/test/Servant/ServerSpec.hs
View file

@ -17,7 +17,6 @@ import Control.Monad.Trans.Except (ExceptT, throwE)
import Data.Aeson (FromJSON, ToJSON, decode', encode) import Data.Aeson (FromJSON, ToJSON, decode', encode)
import Data.ByteString.Conversion () import Data.ByteString.Conversion ()
import Data.Char (toUpper) import Data.Char (toUpper)
import Data.Monoid ((<>))
import Data.Proxy (Proxy (Proxy)) import Data.Proxy (Proxy (Proxy))
import Data.String (fromString) import Data.String (fromString)
import Data.String.Conversions (cs) import Data.String.Conversions (cs)
@ -26,8 +25,7 @@ import GHC.Generics (Generic)
import Network.HTTP.Types (hAccept, hContentType, import Network.HTTP.Types (hAccept, hContentType,
methodDelete, methodGet, methodHead, methodDelete, methodGet, methodHead,
methodPatch, methodPost, methodPut, methodPatch, methodPost, methodPut,
ok200, parseQuery, status409, ok200, parseQuery, Status(..))
Status(..))
import Network.Wai (Application, Request, pathInfo, import Network.Wai (Application, Request, pathInfo,
queryString, rawQueryString, queryString, rawQueryString,
responseLBS, responseBuilder) responseLBS, responseBuilder)
@ -99,7 +97,6 @@ spec = do
rawSpec rawSpec
unionSpec unionSpec
prioErrorsSpec prioErrorsSpec
errorsSpec
routerSpec routerSpec
responseHeadersSpec responseHeadersSpec
miscReqCombinatorsSpec miscReqCombinatorsSpec
@ -158,9 +155,9 @@ getSpec = do
it "returns 204 if the type is '()'" $ do it "returns 204 if the type is '()'" $ do
get "/empty" `shouldRespondWith` ""{ matchStatus = 204 } get "/empty" `shouldRespondWith` ""{ matchStatus = 204 }
it "returns 415 if the Accept header is not supported" $ do it "returns 406 if the Accept header is not supported" $ do
Test.Hspec.Wai.request methodGet "" [(hAccept, "crazy/mime")] "" Test.Hspec.Wai.request methodGet "" [(hAccept, "crazy/mime")] ""
`shouldRespondWith` 415 `shouldRespondWith` 406
headSpec :: Spec headSpec :: Spec
@ -186,9 +183,9 @@ headSpec = do
response <- Test.Hspec.Wai.request methodHead "/empty" [] "" response <- Test.Hspec.Wai.request methodHead "/empty" [] ""
return response `shouldRespondWith` ""{ matchStatus = 204 } return response `shouldRespondWith` ""{ matchStatus = 204 }
it "returns 415 if the Accept header is not supported" $ do it "returns 406 if the Accept header is not supported" $ do
Test.Hspec.Wai.request methodHead "" [(hAccept, "crazy/mime")] "" Test.Hspec.Wai.request methodHead "" [(hAccept, "crazy/mime")] ""
`shouldRespondWith` 415 `shouldRespondWith` 406
type QueryParamApi = QueryParam "name" String :> Get '[JSON] Person type QueryParamApi = QueryParam "name" String :> Get '[JSON] Person
@ -311,7 +308,7 @@ postSpec = do
it "returns 204 if the type is '()'" $ do it "returns 204 if the type is '()'" $ do
post' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 } post' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 }
it "responds with 415 if the requested media type is unsupported" $ do it "responds with 415 if the request body media type is unsupported" $ do
let post'' x = Test.Hspec.Wai.request methodPost x [(hContentType let post'' x = Test.Hspec.Wai.request methodPost x [(hContentType
, "application/nonsense")] , "application/nonsense")]
post'' "/" "anything at all" `shouldRespondWith` 415 post'' "/" "anything at all" `shouldRespondWith` 415
@ -353,7 +350,7 @@ putSpec = do
it "returns 204 if the type is '()'" $ do it "returns 204 if the type is '()'" $ do
put' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 } put' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 }
it "responds with 415 if the requested media type is unsupported" $ do it "responds with 415 if the request body media type is unsupported" $ do
let put'' x = Test.Hspec.Wai.request methodPut x [(hContentType let put'' x = Test.Hspec.Wai.request methodPut x [(hContentType
, "application/nonsense")] , "application/nonsense")]
put'' "/" "anything at all" `shouldRespondWith` 415 put'' "/" "anything at all" `shouldRespondWith` 415
@ -395,7 +392,7 @@ patchSpec = do
it "returns 204 if the type is '()'" $ do it "returns 204 if the type is '()'" $ do
patch' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 } patch' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 }
it "responds with 415 if the requested media type is unsupported" $ do it "responds with 415 if the request body media type is unsupported" $ do
let patch'' x = Test.Hspec.Wai.request methodPatch x [(hContentType let patch'' x = Test.Hspec.Wai.request methodPatch x [(hContentType
, "application/nonsense")] , "application/nonsense")]
patch'' "/" "anything at all" `shouldRespondWith` 415 patch'' "/" "anything at all" `shouldRespondWith` 415
@ -524,10 +521,10 @@ responseHeadersSpec = describe "ResponseHeaders" $ do
Test.Hspec.Wai.request method "blahblah" [] "" Test.Hspec.Wai.request method "blahblah" [] ""
`shouldRespondWith` 404 `shouldRespondWith` 404
it "returns 415 if the Accept header is not supported" $ it "returns 406 if the Accept header is not supported" $
forM_ methods $ \(method,_) -> forM_ methods $ \(method,_) ->
Test.Hspec.Wai.request method "" [(hAccept, "crazy/mime")] "" Test.Hspec.Wai.request method "" [(hAccept, "crazy/mime")] ""
`shouldRespondWith` 415 `shouldRespondWith` 406
type PrioErrorsApi = ReqBody '[JSON] Person :> "foo" :> Get '[JSON] Integer type PrioErrorsApi = ReqBody '[JSON] Person :> "foo" :> Get '[JSON] Integer
@ -578,50 +575,6 @@ prioErrorsSpec = describe "PrioErrors" $ do
check put' "/bar" vjson 404 check put' "/bar" vjson 404
check put' "/foo" vjson 405 check put' "/foo" vjson 405
-- | Test server error functionality.
errorsSpec :: Spec
errorsSpec = do
let he = HttpError status409 (Just "A custom error")
let ib = InvalidBody "The body is invalid"
let wm = WrongMethod
let nf = NotFound
describe "Servant.Server.Internal.RouteMismatch" $ do
it "HttpError > *" $ do
ib <> he `shouldBe` he
wm <> he `shouldBe` he
nf <> he `shouldBe` he
he <> ib `shouldBe` he
he <> wm `shouldBe` he
he <> nf `shouldBe` he
it "HE > InvalidBody > (WM,NF)" $ do
he <> ib `shouldBe` he
wm <> ib `shouldBe` ib
nf <> ib `shouldBe` ib
ib <> he `shouldBe` he
ib <> wm `shouldBe` ib
ib <> nf `shouldBe` ib
it "HE > IB > WrongMethod > NF" $ do
he <> wm `shouldBe` he
ib <> wm `shouldBe` ib
nf <> wm `shouldBe` wm
wm <> he `shouldBe` he
wm <> ib `shouldBe` ib
wm <> nf `shouldBe` wm
it "* > NotFound" $ do
he <> nf `shouldBe` he
ib <> nf `shouldBe` ib
wm <> nf `shouldBe` wm
nf <> he `shouldBe` he
nf <> ib `shouldBe` ib
nf <> wm `shouldBe` wm
routerSpec :: Spec routerSpec :: Spec
routerSpec = do routerSpec = do

15
servant/test/Servant/API/ContentTypesSpec.hs
View file

@ -3,6 +3,7 @@
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-orphans #-}
module Servant.API.ContentTypesSpec where module Servant.API.ContentTypesSpec where
@ -34,6 +35,20 @@ import Servant.API.ContentTypes
spec :: Spec spec :: Spec
spec = describe "Servant.API.ContentTypes" $ do spec = describe "Servant.API.ContentTypes" $ do
describe "handleAcceptH" $ do
let p = Proxy :: Proxy '[PlainText]
it "matches any charset if none were provided" $ do
let without = handleAcceptH p (AcceptHeader "text/plain")
with = handleAcceptH p (AcceptHeader "text/plain;charset=utf-8")
wisdom = "ubi sub ubi" :: String
without wisdom `shouldBe` with wisdom
it "does not match non utf-8 charsets" $ do
let badCharset = handleAcceptH p (AcceptHeader "text/plain;charset=whoknows")
s = "cheese" :: String
badCharset s `shouldBe` Nothing
describe "The JSON Content-Type type" $ do describe "The JSON Content-Type type" $ do
let p = Proxy :: Proxy JSON let p = Proxy :: Proxy JSON