Refactor RouteResult.
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
parent
153de01a62
commit
a3b5652ab9
|
|
@ -5,6 +5,7 @@
|
|||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
import Data.Aeson
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Text (Text)
|
||||
|
|
@ -31,12 +32,12 @@ instance HasServer rest => HasServer (AuthProtected :> rest) where
|
|||
route Proxy a = WithRequest $ \ request ->
|
||||
route (Proxy :: Proxy rest) $ do
|
||||
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
|
||||
authGranted <- isGoodCookie v
|
||||
if authGranted
|
||||
then a
|
||||
else return $ failWith $ HttpError status403 (Just "Invalid cookie.")
|
||||
else return $! failFatallyWith err403 { errBody = "Invalid cookie" }
|
||||
|
||||
type PrivateAPI = Get '[JSON] [PrivateData]
|
||||
|
||||
|
|
|
|||
|
|
@ -103,7 +103,7 @@ import Servant.Server.Internal.Enter
|
|||
-- > main = Network.Wai.Handler.Warp.run 8080 app
|
||||
--
|
||||
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
|
||||
|
|
|
|||
|
|
@ -113,11 +113,10 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout)
|
|||
a -> ServerT sublayout m
|
||||
|
||||
route Proxy subserver =
|
||||
DynamicRouter $ \ first ->
|
||||
route (Proxy :: Proxy sublayout)
|
||||
(case captured captureProxy first of
|
||||
Nothing -> return $ failWith NotFound
|
||||
Just v -> feedTo subserver v)
|
||||
DynamicRouter $ \ first -> case captured captureProxy first of
|
||||
Nothing -> LeafRouter (\_ r -> r $ failWith err404)
|
||||
Just v -> route (Proxy :: Proxy sublayout) (feedTo subserver v)
|
||||
|
||||
where captureProxy = Proxy :: Proxy (Capture capture a)
|
||||
|
||||
allowedMethodHead :: Method -> Request -> Bool
|
||||
|
|
@ -131,7 +130,7 @@ processMethodRouter :: forall a. ConvertibleStrings a B.ByteString
|
|||
-> Maybe [(HeaderName, B.ByteString)]
|
||||
-> Request -> RouteResult Response
|
||||
processMethodRouter handleA status method headers request = case handleA of
|
||||
Nothing -> failWith UnsupportedMediaType
|
||||
Nothing -> failFatallyWith err406
|
||||
Just (contentT, body) -> succeedWith $ responseLBS status hdrs bdy
|
||||
where
|
||||
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
|
||||
processMethodRouter handleA status method Nothing request
|
||||
| pathIsEmpty request && requestMethod request /= method =
|
||||
respond $ failWith WrongMethod
|
||||
| otherwise = respond $ failWith NotFound
|
||||
respond $ failWith err405
|
||||
| otherwise = respond $ failWith err404
|
||||
|
||||
methodRouterHeaders :: (GetHeaders (Headers h v), AllCTRender ctypes v)
|
||||
=> Method -> Proxy ctypes -> Status
|
||||
|
|
@ -167,8 +166,8 @@ methodRouterHeaders method proxy status action = LeafRouter route'
|
|||
handleA = handleAcceptH proxy (AcceptHeader accH) (getResponse output)
|
||||
processMethodRouter handleA status method (Just headers) request
|
||||
| pathIsEmpty request && requestMethod request /= method =
|
||||
respond $ failWith WrongMethod
|
||||
| otherwise = respond $ failWith NotFound
|
||||
respond $ failWith err405
|
||||
| otherwise = respond $ failWith err404
|
||||
|
||||
methodRouterEmpty :: Method
|
||||
-> IO (RouteResult (ExceptT ServantErr IO ()))
|
||||
|
|
@ -180,8 +179,8 @@ methodRouterEmpty method action = LeafRouter route'
|
|||
runAction action respond $ \ () ->
|
||||
succeedWith $ responseLBS noContent204 [] ""
|
||||
| pathIsEmpty request && requestMethod request /= method =
|
||||
respond $ failWith WrongMethod
|
||||
| otherwise = respond $ failWith NotFound
|
||||
respond $ failWith err405
|
||||
| otherwise = respond $ failWith err404
|
||||
|
||||
-- | If you have a 'Delete' endpoint in your API,
|
||||
-- the handler for this endpoint is meant to delete
|
||||
|
|
@ -558,8 +557,9 @@ instance HasServer Raw where
|
|||
route Proxy rawApplication = LeafRouter $ \ request respond -> do
|
||||
r <- rawApplication
|
||||
case r of
|
||||
RR (Left err) -> respond $ failWith err
|
||||
RR (Right app) -> app request (respond . succeedWith)
|
||||
HandlerVal 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,
|
||||
-- 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)
|
||||
<$> lazyRequestBody request
|
||||
case mrqbody of
|
||||
Nothing -> return $ failWith $ UnsupportedMediaType
|
||||
Just (Left e) -> return $ failWith $ InvalidBody e
|
||||
Nothing -> return $! failFatallyWith err415
|
||||
Just (Left e) -> return $! failFatallyWith err400 { errBody = cs e }
|
||||
Just (Right v) -> feedTo subserver v
|
||||
|
||||
-- | Make sure the incoming request starts with @"/path"@, strip it and
|
||||
|
|
|
|||
|
|
@ -7,6 +7,8 @@ import qualified Data.Map as M
|
|||
import Data.Monoid ((<>))
|
||||
import Data.Text (Text)
|
||||
import Network.Wai (Request, Response, pathInfo)
|
||||
import Servant.Server.Internal.ServantErr
|
||||
import Servant.Server.Internal.PathInfo
|
||||
import Servant.Server.Internal.RoutingApplication
|
||||
|
||||
type Router = Router' RoutingApplication
|
||||
|
|
@ -63,17 +65,24 @@ runRouter (StaticRouter table) request respond =
|
|||
| Just router <- M.lookup first table
|
||||
-> let request' = request { pathInfo = rest }
|
||||
in runRouter router request' respond
|
||||
_ -> respond $ failWith NotFound
|
||||
_ -> respond $ failWith err404
|
||||
runRouter (DynamicRouter fun) request respond =
|
||||
case pathInfo request of
|
||||
first : rest
|
||||
-> let request' = request { pathInfo = rest }
|
||||
in runRouter (fun first) request' respond
|
||||
_ -> respond $ failWith NotFound
|
||||
_ -> respond $ failWith err404
|
||||
runRouter (LeafRouter app) request respond = app request respond
|
||||
runRouter (Choice r1 r2) request respond =
|
||||
runRouter r1 request $ \ mResponse1 ->
|
||||
if isMismatch mResponse1
|
||||
then runRouter r2 request $ \ mResponse2 ->
|
||||
respond (mResponse1 <> mResponse2)
|
||||
respond (highestPri mResponse1 mResponse2)
|
||||
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
|
||||
|
|
|
|||
|
|
@ -1,4 +1,5 @@
|
|||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DeriveFunctor #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
|
@ -6,21 +7,17 @@ module Servant.Server.Internal.RoutingApplication where
|
|||
|
||||
#if !MIN_VERSION_base(4,8,0)
|
||||
import Control.Applicative (Applicative, (<$>))
|
||||
import Data.Monoid (Monoid, mappend, mempty)
|
||||
import Data.Monoid (Monoid, mappend, mempty,
|
||||
(<>))
|
||||
#endif
|
||||
import Control.Monad.Trans.Except (ExceptT, runExceptT)
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import Data.IORef (newIORef, readIORef,
|
||||
writeIORef)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Monoid ((<>))
|
||||
import Data.String (fromString)
|
||||
import Network.HTTP.Types hiding (Header,
|
||||
ResponseHeaders)
|
||||
import Network.Wai (Application, Request,
|
||||
Response, ResponseReceived,
|
||||
requestBody, responseLBS,
|
||||
requestBody,
|
||||
strictRequestBody)
|
||||
import Servant.API ((:<|>) (..))
|
||||
import Servant.Server.Internal.ServantErr
|
||||
|
|
@ -30,39 +27,12 @@ type RoutingApplication =
|
|||
-> (RouteResult Response -> IO ResponseReceived) -> IO ResponseReceived
|
||||
|
||||
-- | A wrapper around @'Either' 'RouteMismatch' a@.
|
||||
newtype RouteResult a =
|
||||
RR { routeResult :: Either RouteMismatch a }
|
||||
deriving (Eq, Show, Functor, Applicative)
|
||||
|
||||
-- | If we get a `Right`, it has precedence over everything else.
|
||||
--
|
||||
-- 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 RouteResult a =
|
||||
Retriable ServantErr -- ^ Keep trying other paths. The @ServantErr@
|
||||
-- should only be 404 or 405.
|
||||
| NonRetriable ServantErr -- ^ Stop trying.
|
||||
| HandlerVal a
|
||||
deriving (Eq, Show, Read, Functor)
|
||||
|
||||
data ReqBodyState = Uncalled
|
||||
| Called !B.ByteString
|
||||
|
|
@ -91,55 +61,52 @@ toApplication ra request respond = do
|
|||
writeIORef reqBodyRef $ Called bs
|
||||
return B.empty
|
||||
|
||||
ra request{ requestBody = memoReqBody } (routingRespond . routeResult)
|
||||
ra request{ requestBody = memoReqBody } routingRespond
|
||||
where
|
||||
routingRespond :: Either RouteMismatch Response -> IO ResponseReceived
|
||||
routingRespond (Left NotFound) =
|
||||
respond $ responseLBS notFound404 [] "not found"
|
||||
routingRespond (Left WrongMethod) =
|
||||
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
|
||||
routingRespond :: RouteResult Response -> IO ResponseReceived
|
||||
routingRespond (Retriable err) = respond $! responseServantErr err
|
||||
routingRespond (NonRetriable err) = respond $! responseServantErr err
|
||||
routingRespond (HandlerVal v) = respond v
|
||||
|
||||
runAction :: IO (RouteResult (ExceptT ServantErr IO a))
|
||||
-> (RouteResult Response -> IO r)
|
||||
-> (a -> RouteResult Response)
|
||||
-> IO r
|
||||
runAction action respond k = do
|
||||
r <- action
|
||||
go r
|
||||
runAction action respond k = action >>= go >>= respond
|
||||
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
|
||||
respond $ case e of
|
||||
Right x -> k x
|
||||
Left err -> succeedWith $ responseServantErr err
|
||||
go (RR (Left err)) = respond $ failWith err
|
||||
case e of
|
||||
Left err -> return . succeedWith $! responseServantErr err
|
||||
Right x -> return $! k x
|
||||
|
||||
feedTo :: IO (RouteResult (a -> b)) -> a -> IO (RouteResult b)
|
||||
feedTo f x = (($ x) <$>) <$> f
|
||||
|
||||
extractL :: RouteResult (a :<|> b) -> RouteResult a
|
||||
extractL (RR (Right (a :<|> _))) = RR (Right a)
|
||||
extractL (RR (Left err)) = RR (Left err)
|
||||
extractL (HandlerVal (a :<|> _)) = HandlerVal a
|
||||
extractL (Retriable x) = Retriable x
|
||||
extractL (NonRetriable x) = NonRetriable x
|
||||
|
||||
extractR :: RouteResult (a :<|> b) -> RouteResult b
|
||||
extractR (RR (Right (_ :<|> b))) = RR (Right b)
|
||||
extractR (RR (Left err)) = RR (Left err)
|
||||
extractR (HandlerVal (_ :<|> b)) = HandlerVal b
|
||||
extractR (Retriable x) = Retriable x
|
||||
extractR (NonRetriable x) = NonRetriable x
|
||||
|
||||
failWith :: RouteMismatch -> RouteResult a
|
||||
failWith = RR . Left
|
||||
-- | Fail with a @ServantErr@, but keep trying other paths and.
|
||||
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 = RR . Right
|
||||
succeedWith = HandlerVal
|
||||
|
||||
isMismatch :: RouteResult a -> Bool
|
||||
isMismatch (RR (Left _)) = True
|
||||
isMismatch (Retriable _) = True
|
||||
isMismatch _ = False
|
||||
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@ data ServantErr = ServantErr { errHTTPCode :: Int
|
|||
, errReasonPhrase :: String
|
||||
, errBody :: LBS.ByteString
|
||||
, errHeaders :: [HTTP.Header]
|
||||
} deriving (Show, Eq)
|
||||
} deriving (Show, Eq, Read)
|
||||
|
||||
responseServantErr :: ServantErr -> Response
|
||||
responseServantErr ServantErr{..} = responseLBS status errHeaders errBody
|
||||
|
|
|
|||
|
|
@ -7,9 +7,9 @@ module Servant.Server.ErrorSpec (spec) where
|
|||
|
||||
import Data.Aeson (encode)
|
||||
import qualified Data.ByteString.Lazy.Char8 as BC
|
||||
import Control.Monad.Trans.Either (left)
|
||||
import Data.Proxy
|
||||
import Network.HTTP.Types (methodGet, methodPost)
|
||||
import Network.HTTP.Types (hAccept, hContentType, methodGet,
|
||||
methodPost)
|
||||
import Test.Hspec
|
||||
import Test.Hspec.Wai
|
||||
|
||||
|
|
@ -31,8 +31,9 @@ import Servant
|
|||
|
||||
spec :: Spec
|
||||
spec = describe "HTTP Errors" $ do
|
||||
errorOrder
|
||||
errorRetry
|
||||
errorOrderSpec
|
||||
errorRetrySpec
|
||||
errorChoiceSpec
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- * Error Order {{{
|
||||
|
|
@ -42,24 +43,24 @@ type ErrorOrderApi = "home"
|
|||
:> Capture "t" Int
|
||||
:> Post '[JSON] Int
|
||||
|
||||
|
||||
errorOrderApi :: Proxy ErrorOrderApi
|
||||
errorOrderApi = Proxy
|
||||
|
||||
errorOrderServer :: Server ErrorOrderApi
|
||||
errorOrderServer = \_ _ -> left err402
|
||||
errorOrderServer = \_ _ -> return 5
|
||||
|
||||
errorOrder :: Spec
|
||||
errorOrder = describe "HTTP error order"
|
||||
errorOrderSpec :: Spec
|
||||
errorOrderSpec = describe "HTTP error order"
|
||||
$ with (return $ serve errorOrderApi errorOrderServer) $ do
|
||||
let badContentType = ("Content-Type", "text/plain")
|
||||
badAccept = ("Accept", "text/plain")
|
||||
let badContentType = (hContentType, "text/plain")
|
||||
badAccept = (hAccept, "text/plain")
|
||||
badMethod = methodGet
|
||||
badUrl = "home/nonexistent"
|
||||
badBody = "nonsense"
|
||||
goodContentType = ("Content-Type", "application/json")
|
||||
goodAccept = ("Accept", "application/json")
|
||||
goodContentType = (hContentType, "application/json")
|
||||
goodMethod = methodPost
|
||||
goodUrl = "home/5"
|
||||
goodUrl = "home/2"
|
||||
goodBody = encode (5 :: Int)
|
||||
|
||||
it "has 404 as its highest priority error" $ do
|
||||
|
|
@ -82,10 +83,6 @@ errorOrder = describe "HTTP error order"
|
|||
request goodMethod goodUrl [goodContentType, badAccept] goodBody
|
||||
`shouldRespondWith` 406
|
||||
|
||||
it "returns handler errors as its lower priority errors" $ do
|
||||
request goodMethod goodUrl [goodContentType, goodAccept] goodBody
|
||||
`shouldRespondWith` 402
|
||||
|
||||
-- }}}
|
||||
------------------------------------------------------------------------------
|
||||
-- * Error Retry {{{
|
||||
|
|
@ -95,9 +92,10 @@ type ErrorRetryApi
|
|||
:<|> "a" :> ReqBody '[PlainText] Int :> Post '[JSON] Int -- 1
|
||||
:<|> "a" :> ReqBody '[JSON] Int :> Post '[PlainText] Int -- 2
|
||||
:<|> "a" :> ReqBody '[JSON] String :> Post '[JSON] Int -- 3
|
||||
:<|> "a" :> ReqBody '[JSON] Int :> Get '[PlainText] Int -- 4
|
||||
:<|> ReqBody '[JSON] Int :> Get '[JSON] Int -- 5
|
||||
:<|> "a" :> ReqBody '[JSON] Int :> Get '[JSON] Int -- 4
|
||||
:<|> "a" :> ReqBody '[JSON] Int :> Get '[PlainText] Int -- 5
|
||||
:<|> ReqBody '[JSON] Int :> Get '[JSON] Int -- 6
|
||||
:<|> ReqBody '[JSON] Int :> Post '[JSON] Int -- 7
|
||||
|
||||
errorRetryApi :: Proxy ErrorRetryApi
|
||||
errorRetryApi = Proxy
|
||||
|
|
@ -111,19 +109,21 @@ errorRetryServer
|
|||
:<|> (\_ -> return 4)
|
||||
:<|> (\_ -> return 5)
|
||||
:<|> (\_ -> return 6)
|
||||
:<|> (\_ -> return 7)
|
||||
|
||||
errorRetry :: Spec
|
||||
errorRetry = describe "Handler search"
|
||||
errorRetrySpec :: Spec
|
||||
errorRetrySpec = describe "Handler search"
|
||||
$ with (return $ serve errorRetryApi errorRetryServer) $ do
|
||||
let plainCT = ("Content-Type", "text/plain")
|
||||
plainAccept = ("Accept", "text/plain")
|
||||
jsonCT = ("Content-Type", "application/json")
|
||||
jsonAccept = ("Accept", "application/json")
|
||||
|
||||
let plainCT = (hContentType, "text/plain")
|
||||
plainAccept = (hAccept, "text/plain")
|
||||
jsonCT = (hContentType, "application/json")
|
||||
jsonAccept = (hAccept, "application/json")
|
||||
jsonBody = encode (1797 :: Int)
|
||||
|
||||
it "should continue when URLs don't match" $ do
|
||||
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
|
||||
request methodGet "a" [jsonCT, jsonAccept] jsonBody
|
||||
|
|
@ -141,6 +141,50 @@ errorRetry = describe "Handler search"
|
|||
request methodPost "a" [jsonCT, plainAccept] jsonBody
|
||||
`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 {{{
|
||||
|
|
|
|||
|
|
@ -17,7 +17,6 @@ import Control.Monad.Trans.Except (ExceptT, throwE)
|
|||
import Data.Aeson (FromJSON, ToJSON, decode', encode)
|
||||
import Data.ByteString.Conversion ()
|
||||
import Data.Char (toUpper)
|
||||
import Data.Monoid ((<>))
|
||||
import Data.Proxy (Proxy (Proxy))
|
||||
import Data.String (fromString)
|
||||
import Data.String.Conversions (cs)
|
||||
|
|
@ -26,8 +25,7 @@ import GHC.Generics (Generic)
|
|||
import Network.HTTP.Types (hAccept, hContentType,
|
||||
methodDelete, methodGet, methodHead,
|
||||
methodPatch, methodPost, methodPut,
|
||||
ok200, parseQuery, status409,
|
||||
Status(..))
|
||||
ok200, parseQuery, Status(..))
|
||||
import Network.Wai (Application, Request, pathInfo,
|
||||
queryString, rawQueryString,
|
||||
responseLBS, responseBuilder)
|
||||
|
|
@ -99,7 +97,6 @@ spec = do
|
|||
rawSpec
|
||||
unionSpec
|
||||
prioErrorsSpec
|
||||
errorsSpec
|
||||
routerSpec
|
||||
responseHeadersSpec
|
||||
miscReqCombinatorsSpec
|
||||
|
|
@ -158,9 +155,9 @@ getSpec = do
|
|||
it "returns 204 if the type is '()'" $ do
|
||||
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")] ""
|
||||
`shouldRespondWith` 415
|
||||
`shouldRespondWith` 406
|
||||
|
||||
|
||||
headSpec :: Spec
|
||||
|
|
@ -186,9 +183,9 @@ headSpec = do
|
|||
response <- Test.Hspec.Wai.request methodHead "/empty" [] ""
|
||||
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")] ""
|
||||
`shouldRespondWith` 415
|
||||
`shouldRespondWith` 406
|
||||
|
||||
|
||||
type QueryParamApi = QueryParam "name" String :> Get '[JSON] Person
|
||||
|
|
@ -311,7 +308,7 @@ postSpec = do
|
|||
it "returns 204 if the type is '()'" $ do
|
||||
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
|
||||
, "application/nonsense")]
|
||||
post'' "/" "anything at all" `shouldRespondWith` 415
|
||||
|
|
@ -353,7 +350,7 @@ putSpec = do
|
|||
it "returns 204 if the type is '()'" $ do
|
||||
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
|
||||
, "application/nonsense")]
|
||||
put'' "/" "anything at all" `shouldRespondWith` 415
|
||||
|
|
@ -395,7 +392,7 @@ patchSpec = do
|
|||
it "returns 204 if the type is '()'" $ do
|
||||
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
|
||||
, "application/nonsense")]
|
||||
patch'' "/" "anything at all" `shouldRespondWith` 415
|
||||
|
|
@ -524,10 +521,10 @@ responseHeadersSpec = describe "ResponseHeaders" $ do
|
|||
Test.Hspec.Wai.request method "blahblah" [] ""
|
||||
`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,_) ->
|
||||
Test.Hspec.Wai.request method "" [(hAccept, "crazy/mime")] ""
|
||||
`shouldRespondWith` 415
|
||||
`shouldRespondWith` 406
|
||||
|
||||
type PrioErrorsApi = ReqBody '[JSON] Person :> "foo" :> Get '[JSON] Integer
|
||||
|
||||
|
|
@ -578,50 +575,6 @@ prioErrorsSpec = describe "PrioErrors" $ do
|
|||
check put' "/bar" vjson 404
|
||||
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 = do
|
||||
|
|
|
|||
|
|
@ -3,6 +3,7 @@
|
|||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
module Servant.API.ContentTypesSpec where
|
||||
|
||||
|
|
@ -34,6 +35,20 @@ import Servant.API.ContentTypes
|
|||
spec :: Spec
|
||||
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
|
||||
let p = Proxy :: Proxy JSON
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user