Merge pull request #218 from haskell-servant/jkarni/http-errors
Fix error priority and retries
This commit is contained in:
Julian Arni
commit
6a4c967590
14 changed files with 635 additions and 342 deletions
|
|
@ -496,19 +496,6 @@ sampleByteStrings ctypes@Proxy Proxy =
|
|||
enc (t, s) = uncurry (t,,) <$> allMimeRender ctypes s
|
||||
in concatMap enc samples'
|
||||
|
||||
-- | Generate a list of 'MediaType' values describing the content types
|
||||
-- accepted by an API component.
|
||||
class SupportedTypes (list :: [*]) where
|
||||
supportedTypes :: Proxy list -> [M.MediaType]
|
||||
|
||||
instance SupportedTypes '[] where
|
||||
supportedTypes Proxy = []
|
||||
|
||||
instance (Accept ctype, SupportedTypes rest) => SupportedTypes (ctype ': rest)
|
||||
where
|
||||
supportedTypes Proxy =
|
||||
contentType (Proxy :: Proxy ctype) : supportedTypes (Proxy :: Proxy rest)
|
||||
|
||||
-- | The class that helps us automatically get documentation
|
||||
-- for GET parameters.
|
||||
--
|
||||
|
|
@ -709,14 +696,14 @@ instance
|
|||
#if MIN_VERSION_base(4,8,0)
|
||||
{-# OVERLAPPABLe #-}
|
||||
#endif
|
||||
(ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)
|
||||
(ToSample a, IsNonEmpty cts, AllMimeRender cts a)
|
||||
=> HasDocs (Delete cts a) where
|
||||
docsFor Proxy (endpoint, action) DocOptions{..} =
|
||||
single endpoint' action'
|
||||
|
||||
where endpoint' = endpoint & method .~ DocDELETE
|
||||
action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
|
||||
& response.respTypes .~ supportedTypes t
|
||||
& response.respTypes .~ allMime t
|
||||
t = Proxy :: Proxy cts
|
||||
p = Proxy :: Proxy a
|
||||
|
||||
|
|
@ -724,7 +711,7 @@ instance
|
|||
#if MIN_VERSION_base(4,8,0)
|
||||
{-# OVERLAPPING #-}
|
||||
#endif
|
||||
(ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts
|
||||
(ToSample a, IsNonEmpty cts, AllMimeRender cts a
|
||||
, AllHeaderSamples ls , GetHeaders (HList ls) )
|
||||
=> HasDocs (Delete cts (Headers ls a)) where
|
||||
docsFor Proxy (endpoint, action) DocOptions{..} =
|
||||
|
|
@ -733,7 +720,7 @@ instance
|
|||
where hdrs = allHeaderToSample (Proxy :: Proxy ls)
|
||||
endpoint' = endpoint & method .~ DocDELETE
|
||||
action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
|
||||
& response.respTypes .~ supportedTypes t
|
||||
& response.respTypes .~ allMime t
|
||||
& response.respHeaders .~ hdrs
|
||||
t = Proxy :: Proxy cts
|
||||
p = Proxy :: Proxy a
|
||||
|
|
@ -742,14 +729,14 @@ instance
|
|||
#if MIN_VERSION_base(4,8,0)
|
||||
{-# OVERLAPPABLe #-}
|
||||
#endif
|
||||
(ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)
|
||||
(ToSample a, IsNonEmpty cts, AllMimeRender cts a)
|
||||
=> HasDocs (Get cts a) where
|
||||
docsFor Proxy (endpoint, action) DocOptions{..} =
|
||||
single endpoint' action'
|
||||
|
||||
where endpoint' = endpoint & method .~ DocGET
|
||||
action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
|
||||
& response.respTypes .~ supportedTypes t
|
||||
& response.respTypes .~ allMime t
|
||||
t = Proxy :: Proxy cts
|
||||
p = Proxy :: Proxy a
|
||||
|
||||
|
|
@ -757,7 +744,7 @@ instance
|
|||
#if MIN_VERSION_base(4,8,0)
|
||||
{-# OVERLAPPING #-}
|
||||
#endif
|
||||
(ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts
|
||||
(ToSample a, IsNonEmpty cts, AllMimeRender cts a
|
||||
, AllHeaderSamples ls , GetHeaders (HList ls) )
|
||||
=> HasDocs (Get cts (Headers ls a)) where
|
||||
docsFor Proxy (endpoint, action) DocOptions{..} =
|
||||
|
|
@ -766,7 +753,7 @@ instance
|
|||
where hdrs = allHeaderToSample (Proxy :: Proxy ls)
|
||||
endpoint' = endpoint & method .~ DocGET
|
||||
action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
|
||||
& response.respTypes .~ supportedTypes t
|
||||
& response.respTypes .~ allMime t
|
||||
& response.respHeaders .~ hdrs
|
||||
t = Proxy :: Proxy cts
|
||||
p = Proxy :: Proxy a
|
||||
|
|
@ -784,14 +771,14 @@ instance
|
|||
#if MIN_VERSION_base(4,8,0)
|
||||
{-# OVERLAPPABLE #-}
|
||||
#endif
|
||||
(ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)
|
||||
(ToSample a, IsNonEmpty cts, AllMimeRender cts a)
|
||||
=> HasDocs (Post cts a) where
|
||||
docsFor Proxy (endpoint, action) DocOptions{..} =
|
||||
single endpoint' action'
|
||||
|
||||
where endpoint' = endpoint & method .~ DocPOST
|
||||
action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
|
||||
& response.respTypes .~ supportedTypes t
|
||||
& response.respTypes .~ allMime t
|
||||
& response.respStatus .~ 201
|
||||
t = Proxy :: Proxy cts
|
||||
p = Proxy :: Proxy a
|
||||
|
|
@ -800,7 +787,7 @@ instance
|
|||
#if MIN_VERSION_base(4,8,0)
|
||||
{-# OVERLAPPING #-}
|
||||
#endif
|
||||
(ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts
|
||||
(ToSample a, IsNonEmpty cts, AllMimeRender cts a
|
||||
, AllHeaderSamples ls , GetHeaders (HList ls) )
|
||||
=> HasDocs (Post cts (Headers ls a)) where
|
||||
docsFor Proxy (endpoint, action) DocOptions{..} =
|
||||
|
|
@ -809,7 +796,7 @@ instance
|
|||
where hdrs = allHeaderToSample (Proxy :: Proxy ls)
|
||||
endpoint' = endpoint & method .~ DocPOST
|
||||
action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
|
||||
& response.respTypes .~ supportedTypes t
|
||||
& response.respTypes .~ allMime t
|
||||
& response.respStatus .~ 201
|
||||
& response.respHeaders .~ hdrs
|
||||
t = Proxy :: Proxy cts
|
||||
|
|
@ -819,14 +806,14 @@ instance
|
|||
#if MIN_VERSION_base(4,8,0)
|
||||
{-# OVERLAPPABLE #-}
|
||||
#endif
|
||||
(ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)
|
||||
(ToSample a, IsNonEmpty cts, AllMimeRender cts a)
|
||||
=> HasDocs (Put cts a) where
|
||||
docsFor Proxy (endpoint, action) DocOptions{..} =
|
||||
single endpoint' action'
|
||||
|
||||
where endpoint' = endpoint & method .~ DocPUT
|
||||
action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
|
||||
& response.respTypes .~ supportedTypes t
|
||||
& response.respTypes .~ allMime t
|
||||
& response.respStatus .~ 200
|
||||
t = Proxy :: Proxy cts
|
||||
p = Proxy :: Proxy a
|
||||
|
|
@ -835,8 +822,8 @@ instance
|
|||
#if MIN_VERSION_base(4,8,0)
|
||||
{-# OVERLAPPING #-}
|
||||
#endif
|
||||
(ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts
|
||||
, AllHeaderSamples ls , GetHeaders (HList ls) )
|
||||
( ToSample a, IsNonEmpty cts, AllMimeRender cts a,
|
||||
AllHeaderSamples ls , GetHeaders (HList ls) )
|
||||
=> HasDocs (Put cts (Headers ls a)) where
|
||||
docsFor Proxy (endpoint, action) DocOptions{..} =
|
||||
single endpoint' action'
|
||||
|
|
@ -844,7 +831,7 @@ instance
|
|||
where hdrs = allHeaderToSample (Proxy :: Proxy ls)
|
||||
endpoint' = endpoint & method .~ DocPUT
|
||||
action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
|
||||
& response.respTypes .~ supportedTypes t
|
||||
& response.respTypes .~ allMime t
|
||||
& response.respStatus .~ 200
|
||||
& response.respHeaders .~ hdrs
|
||||
t = Proxy :: Proxy cts
|
||||
|
|
@ -890,8 +877,7 @@ instance HasDocs Raw where
|
|||
-- example data. However, there's no reason to believe that the instances of
|
||||
-- 'AllMimeUnrender' and 'AllMimeRender' actually agree (or to suppose that
|
||||
-- both are even defined) for any particular type.
|
||||
instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, HasDocs sublayout
|
||||
, SupportedTypes cts)
|
||||
instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, HasDocs sublayout)
|
||||
=> HasDocs (ReqBody cts a :> sublayout) where
|
||||
|
||||
docsFor Proxy (endpoint, action) =
|
||||
|
|
@ -899,7 +885,7 @@ instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, HasDocs sublayout
|
|||
|
||||
where sublayoutP = Proxy :: Proxy sublayout
|
||||
action' = action & rqbody .~ sampleByteString t p
|
||||
& rqtypes .~ supportedTypes t
|
||||
& rqtypes .~ allMime t
|
||||
t = Proxy :: Proxy cts
|
||||
p = Proxy :: Proxy a
|
||||
|
||||
|
|
@ -957,4 +943,3 @@ instance ToSample a => ToSample (Product a)
|
|||
instance ToSample a => ToSample (First a)
|
||||
instance ToSample a => ToSample (Last a)
|
||||
instance ToSample a => ToSample (Dual a)
|
||||
|
||||
|
|
|
|||
|
|
@ -5,11 +5,11 @@
|
|||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
import Data.Aeson
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Text (Text)
|
||||
import GHC.Generics
|
||||
import Network.HTTP.Types
|
||||
import Network.Wai
|
||||
import Network.Wai.Handler.Warp
|
||||
import Servant
|
||||
|
|
@ -28,15 +28,16 @@ data AuthProtected
|
|||
instance HasServer rest => HasServer (AuthProtected :> rest) where
|
||||
type ServerT (AuthProtected :> rest) m = ServerT rest m
|
||||
|
||||
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.")
|
||||
Just v -> do
|
||||
authGranted <- isGoodCookie v
|
||||
if authGranted
|
||||
then a
|
||||
else return $ failWith $ HttpError status403 (Just "Invalid cookie.")
|
||||
route Proxy subserver = WithRequest $ \ request ->
|
||||
route (Proxy :: Proxy rest) $ addAcceptCheck subserver $ cookieCheck request
|
||||
where
|
||||
cookieCheck req = case lookup "Cookie" (requestHeaders req) of
|
||||
Nothing -> return $ FailFatal err401 { errBody = "Missing auth header" }
|
||||
Just v -> do
|
||||
authGranted <- isGoodCookie v
|
||||
if authGranted
|
||||
then return $ Route ()
|
||||
else return $ FailFatal err403 { errBody = "Invalid cookie" }
|
||||
|
||||
type PrivateAPI = Get '[JSON] [PrivateData]
|
||||
|
||||
|
|
|
|||
|
|
@ -5,6 +5,9 @@ HEAD
|
|||
* Drop `EitherT` in favor of `ExceptT`
|
||||
* Use `http-api-data` instead of `Servant.Common.Text`
|
||||
* Remove matrix params.
|
||||
* Remove `RouteMismatch`.
|
||||
* Redefined constructors of `RouteResult`.
|
||||
* Added `Delayed` and related functions (`addMethodCheck`, `addAcceptCheck`, `addBodyCheck`, `runDelayed`)
|
||||
|
||||
0.4.1
|
||||
-----
|
||||
|
|
|
|||
|
|
@ -95,6 +95,7 @@ test-suite spec
|
|||
Servant.Server.Internal.EnterSpec
|
||||
Servant.ServerSpec
|
||||
Servant.Utils.StaticFilesSpec
|
||||
Servant.Server.ErrorSpec
|
||||
build-depends:
|
||||
base == 4.*
|
||||
, aeson
|
||||
|
|
@ -108,6 +109,7 @@ test-suite spec
|
|||
, network >= 2.6
|
||||
, QuickCheck
|
||||
, parsec
|
||||
, safe
|
||||
, servant
|
||||
, servant-server
|
||||
, string-conversions
|
||||
|
|
|
|||
|
|
@ -103,7 +103,10 @@ 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 d))
|
||||
where
|
||||
d = Delayed r r r (\ _ _ -> Route server)
|
||||
r = return (Route ())
|
||||
|
||||
|
||||
-- Documentation
|
||||
|
|
|
|||
|
|
@ -1,15 +1,15 @@
|
|||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
#if !MIN_VERSION_base(4,8,0)
|
||||
{-# LANGUAGE OverlappingInstances #-}
|
||||
{-# LANGUAGE OverlappingInstances #-}
|
||||
#endif
|
||||
|
||||
module Servant.Server.Internal
|
||||
|
|
@ -26,9 +26,9 @@ import Control.Monad.Trans.Except (ExceptT)
|
|||
import qualified Data.ByteString as B
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe (mapMaybe, fromMaybe)
|
||||
import Data.Maybe (fromMaybe, mapMaybe)
|
||||
import Data.String (fromString)
|
||||
import Data.String.Conversions (cs, (<>), ConvertibleStrings)
|
||||
import Data.String.Conversions (ConvertibleStrings, cs, (<>))
|
||||
import Data.Text (Text)
|
||||
import Data.Typeable
|
||||
import GHC.TypeLits (KnownSymbol, symbolVal)
|
||||
|
|
@ -46,9 +46,11 @@ import Servant.API ((:<|>) (..), (:>), Capture,
|
|||
Raw, RemoteHost, ReqBody, Vault)
|
||||
import Servant.API.ContentTypes (AcceptHeader (..),
|
||||
AllCTRender (..),
|
||||
AllCTUnrender (..))
|
||||
import Servant.API.ResponseHeaders (Headers, getResponse, GetHeaders,
|
||||
getHeaders)
|
||||
AllCTUnrender (..),
|
||||
AllMime,
|
||||
canHandleAcceptH)
|
||||
import Servant.API.ResponseHeaders (GetHeaders, Headers, getHeaders,
|
||||
getResponse)
|
||||
|
||||
import Servant.Server.Internal.Router
|
||||
import Servant.Server.Internal.RoutingApplication
|
||||
|
|
@ -60,7 +62,7 @@ import Web.HttpApiData.Internal (parseUrlPieceMaybe, parseHeaderMaybe,
|
|||
class HasServer layout where
|
||||
type ServerT layout (m :: * -> *) :: *
|
||||
|
||||
route :: Proxy layout -> IO (RouteResult (Server layout)) -> Router
|
||||
route :: Proxy layout -> Delayed (Server layout) -> Router
|
||||
|
||||
type Server layout = ServerT layout (ExceptT ServantErr IO)
|
||||
|
||||
|
|
@ -81,8 +83,8 @@ instance (HasServer a, HasServer b) => HasServer (a :<|> b) where
|
|||
|
||||
type ServerT (a :<|> b) m = ServerT a m :<|> ServerT b m
|
||||
|
||||
route Proxy server = choice (route pa (extractL <$> server))
|
||||
(route pb (extractR <$> server))
|
||||
route Proxy server = choice (route pa ((\ (a :<|> _) -> a) <$> server))
|
||||
(route pb ((\ (_ :<|> b) -> b) <$> server))
|
||||
where pa = Proxy :: Proxy a
|
||||
pb = Proxy :: Proxy b
|
||||
|
||||
|
|
@ -112,13 +114,15 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout)
|
|||
type ServerT (Capture capture a :> sublayout) m =
|
||||
a -> ServerT sublayout m
|
||||
|
||||
route Proxy subserver =
|
||||
route Proxy d =
|
||||
DynamicRouter $ \ first ->
|
||||
route (Proxy :: Proxy sublayout)
|
||||
(case captured captureProxy first of
|
||||
Nothing -> return $ failWith NotFound
|
||||
Just v -> feedTo subserver v)
|
||||
where captureProxy = Proxy :: Proxy (Capture capture a)
|
||||
route (Proxy :: Proxy sublayout)
|
||||
(addCapture d $ case captured captureProxy first of
|
||||
Nothing -> return $ Fail err404
|
||||
Just v -> return $ Route v
|
||||
)
|
||||
where
|
||||
captureProxy = Proxy :: Proxy (Capture capture a)
|
||||
|
||||
allowedMethodHead :: Method -> Request -> Bool
|
||||
allowedMethodHead method request = method == methodGet && requestMethod request == methodHead
|
||||
|
|
@ -131,57 +135,65 @@ 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
|
||||
Just (contentT, body) -> succeedWith $ responseLBS status hdrs bdy
|
||||
Nothing -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does
|
||||
Just (contentT, body) -> Route $ responseLBS status hdrs bdy
|
||||
where
|
||||
bdy = if allowedMethodHead method request then "" else body
|
||||
hdrs = (hContentType, cs contentT) : (fromMaybe [] headers)
|
||||
|
||||
methodCheck :: Method -> Request -> IO (RouteResult ())
|
||||
methodCheck method request
|
||||
| allowedMethod method request = return $ Route ()
|
||||
| otherwise = return $ Fail err405
|
||||
|
||||
acceptCheck :: (AllMime list) => Proxy list -> B.ByteString -> IO (RouteResult ())
|
||||
acceptCheck proxy accH
|
||||
| canHandleAcceptH proxy (AcceptHeader accH) = return $ Route ()
|
||||
| otherwise = return $ Fail err406
|
||||
|
||||
methodRouter :: (AllCTRender ctypes a)
|
||||
=> Method -> Proxy ctypes -> Status
|
||||
-> IO (RouteResult (ExceptT ServantErr IO a))
|
||||
-> Delayed (ExceptT ServantErr IO a)
|
||||
-> Router
|
||||
methodRouter method proxy status action = LeafRouter route'
|
||||
where
|
||||
route' request respond
|
||||
| pathIsEmpty request && allowedMethod method request = do
|
||||
runAction action respond $ \ output -> do
|
||||
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
|
||||
handleA = handleAcceptH proxy (AcceptHeader accH) output
|
||||
processMethodRouter handleA status method Nothing request
|
||||
| pathIsEmpty request && requestMethod request /= method =
|
||||
respond $ failWith WrongMethod
|
||||
| otherwise = respond $ failWith NotFound
|
||||
| pathIsEmpty request =
|
||||
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
|
||||
in runAction (action `addMethodCheck` methodCheck method request
|
||||
`addAcceptCheck` acceptCheck proxy accH
|
||||
) respond $ \ output -> do
|
||||
let handleA = handleAcceptH proxy (AcceptHeader accH) output
|
||||
processMethodRouter handleA status method Nothing request
|
||||
| otherwise = respond $ Fail err404
|
||||
|
||||
methodRouterHeaders :: (GetHeaders (Headers h v), AllCTRender ctypes v)
|
||||
=> Method -> Proxy ctypes -> Status
|
||||
-> IO (RouteResult (ExceptT ServantErr IO (Headers h v)))
|
||||
-> Delayed (ExceptT ServantErr IO (Headers h v))
|
||||
-> Router
|
||||
methodRouterHeaders method proxy status action = LeafRouter route'
|
||||
where
|
||||
route' request respond
|
||||
| pathIsEmpty request && allowedMethod method request = do
|
||||
runAction action respond $ \ output -> do
|
||||
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
|
||||
headers = getHeaders output
|
||||
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
|
||||
| pathIsEmpty request =
|
||||
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
|
||||
in runAction (action `addMethodCheck` methodCheck method request
|
||||
`addAcceptCheck` acceptCheck proxy accH
|
||||
) respond $ \ output -> do
|
||||
let headers = getHeaders output
|
||||
handleA = handleAcceptH proxy (AcceptHeader accH) (getResponse output)
|
||||
processMethodRouter handleA status method (Just headers) request
|
||||
| otherwise = respond $ Fail err404
|
||||
|
||||
methodRouterEmpty :: Method
|
||||
-> IO (RouteResult (ExceptT ServantErr IO ()))
|
||||
-> Delayed (ExceptT ServantErr IO ())
|
||||
-> Router
|
||||
methodRouterEmpty method action = LeafRouter route'
|
||||
where
|
||||
route' request respond
|
||||
| pathIsEmpty request && allowedMethod method request = do
|
||||
runAction action respond $ \ () ->
|
||||
succeedWith $ responseLBS noContent204 [] ""
|
||||
| pathIsEmpty request && requestMethod request /= method =
|
||||
respond $ failWith WrongMethod
|
||||
| otherwise = respond $ failWith NotFound
|
||||
| pathIsEmpty request = do
|
||||
runAction (addMethodCheck action (methodCheck method request)) respond $ \ () ->
|
||||
Route $! responseLBS noContent204 [] ""
|
||||
| otherwise = respond $ Fail err404
|
||||
|
||||
-- | If you have a 'Delete' endpoint in your API,
|
||||
-- the handler for this endpoint is meant to delete
|
||||
|
|
@ -301,7 +313,7 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout)
|
|||
|
||||
route Proxy subserver = WithRequest $ \ request ->
|
||||
let mheader = parseHeaderMaybe =<< lookup str (requestHeaders request)
|
||||
in route (Proxy :: Proxy sublayout) (feedTo subserver mheader)
|
||||
in route (Proxy :: Proxy sublayout) (passToServer subserver mheader)
|
||||
where str = fromString $ symbolVal (Proxy :: Proxy sym)
|
||||
|
||||
-- | When implementing the handler for a 'Post' endpoint,
|
||||
|
|
@ -473,7 +485,7 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout)
|
|||
Just Nothing -> Nothing -- param present with no value -> Nothing
|
||||
Just (Just v) -> parseQueryParamMaybe v -- if present, we try to convert to
|
||||
-- the right type
|
||||
in route (Proxy :: Proxy sublayout) (feedTo subserver param)
|
||||
in route (Proxy :: Proxy sublayout) (passToServer subserver param)
|
||||
where paramname = cs $ symbolVal (Proxy :: Proxy sym)
|
||||
|
||||
-- | If you use @'QueryParams' "authors" Text@ in one of the endpoints for your API,
|
||||
|
|
@ -508,7 +520,7 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout)
|
|||
-- corresponding values
|
||||
parameters = filter looksLikeParam querytext
|
||||
values = mapMaybe (convert . snd) parameters
|
||||
in route (Proxy :: Proxy sublayout) (feedTo subserver values)
|
||||
in route (Proxy :: Proxy sublayout) (passToServer subserver values)
|
||||
where paramname = cs $ symbolVal (Proxy :: Proxy sym)
|
||||
looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]")
|
||||
convert Nothing = Nothing
|
||||
|
|
@ -538,7 +550,7 @@ instance (KnownSymbol sym, HasServer sublayout)
|
|||
Just Nothing -> True -- param is there, with no value
|
||||
Just (Just v) -> examine v -- param with a value
|
||||
Nothing -> False -- param not in the query string
|
||||
in route (Proxy :: Proxy sublayout) (feedTo subserver param)
|
||||
in route (Proxy :: Proxy sublayout) (passToServer subserver param)
|
||||
where paramname = cs $ symbolVal (Proxy :: Proxy sym)
|
||||
examine v | v == "true" || v == "1" || v == "" = True
|
||||
| otherwise = False
|
||||
|
|
@ -556,10 +568,11 @@ instance HasServer Raw where
|
|||
type ServerT Raw m = Application
|
||||
|
||||
route Proxy rawApplication = LeafRouter $ \ request respond -> do
|
||||
r <- rawApplication
|
||||
r <- runDelayed rawApplication
|
||||
case r of
|
||||
RR (Left err) -> respond $ failWith err
|
||||
RR (Right app) -> app request (respond . succeedWith)
|
||||
Route app -> app request (respond . Route)
|
||||
Fail a -> respond $ Fail a
|
||||
FailFatal e -> respond $ FailFatal e
|
||||
|
||||
-- | If you use 'ReqBody' in one of the endpoints for your API,
|
||||
-- this automatically requires your server-side handler to be a function
|
||||
|
|
@ -589,19 +602,21 @@ instance ( AllCTUnrender list a, HasServer sublayout
|
|||
a -> ServerT sublayout m
|
||||
|
||||
route Proxy subserver = WithRequest $ \ request ->
|
||||
route (Proxy :: Proxy sublayout) $ do
|
||||
-- See HTTP RFC 2616, section 7.2.1
|
||||
-- http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1
|
||||
-- See also "W3C Internet Media Type registration, consistency of use"
|
||||
-- http://www.w3.org/2001/tag/2002/0129-mime
|
||||
let contentTypeH = fromMaybe "application/octet-stream"
|
||||
$ lookup hContentType $ requestHeaders request
|
||||
mrqbody <- handleCTypeH (Proxy :: Proxy list) (cs contentTypeH)
|
||||
<$> lazyRequestBody request
|
||||
case mrqbody of
|
||||
Nothing -> return $ failWith $ UnsupportedMediaType
|
||||
Just (Left e) -> return $ failWith $ InvalidBody e
|
||||
Just (Right v) -> feedTo subserver v
|
||||
route (Proxy :: Proxy sublayout) (addBodyCheck subserver (bodyCheck request))
|
||||
where
|
||||
bodyCheck request = do
|
||||
-- See HTTP RFC 2616, section 7.2.1
|
||||
-- http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1
|
||||
-- See also "W3C Internet Media Type registration, consistency of use"
|
||||
-- http://www.w3.org/2001/tag/2002/0129-mime
|
||||
let contentTypeH = fromMaybe "application/octet-stream"
|
||||
$ lookup hContentType $ requestHeaders request
|
||||
mrqbody <- handleCTypeH (Proxy :: Proxy list) (cs contentTypeH)
|
||||
<$> lazyRequestBody request
|
||||
case mrqbody of
|
||||
Nothing -> return $ FailFatal err415
|
||||
Just (Left e) -> return $ FailFatal err400 { errBody = cs e }
|
||||
Just (Right v) -> return $ Route v
|
||||
|
||||
-- | Make sure the incoming request starts with @"/path"@, strip it and
|
||||
-- pass the rest of the request path to @sublayout@.
|
||||
|
|
@ -618,13 +633,13 @@ instance HasServer api => HasServer (RemoteHost :> api) where
|
|||
type ServerT (RemoteHost :> api) m = SockAddr -> ServerT api m
|
||||
|
||||
route Proxy subserver = WithRequest $ \req ->
|
||||
route (Proxy :: Proxy api) (feedTo subserver $ remoteHost req)
|
||||
route (Proxy :: Proxy api) (passToServer subserver $ remoteHost req)
|
||||
|
||||
instance HasServer api => HasServer (IsSecure :> api) where
|
||||
type ServerT (IsSecure :> api) m = IsSecure -> ServerT api m
|
||||
|
||||
route Proxy subserver = WithRequest $ \req ->
|
||||
route (Proxy :: Proxy api) (feedTo subserver $ secure req)
|
||||
route (Proxy :: Proxy api) (passToServer subserver $ secure req)
|
||||
|
||||
where secure req = if isSecure req then Secure else NotSecure
|
||||
|
||||
|
|
@ -632,13 +647,13 @@ instance HasServer api => HasServer (Vault :> api) where
|
|||
type ServerT (Vault :> api) m = Vault -> ServerT api m
|
||||
|
||||
route Proxy subserver = WithRequest $ \req ->
|
||||
route (Proxy :: Proxy api) (feedTo subserver $ vault req)
|
||||
route (Proxy :: Proxy api) (passToServer subserver $ vault req)
|
||||
|
||||
instance HasServer api => HasServer (HttpVersion :> api) where
|
||||
type ServerT (HttpVersion :> api) m = HttpVersion -> ServerT api m
|
||||
|
||||
route Proxy subserver = WithRequest $ \req ->
|
||||
route (Proxy :: Proxy api) (feedTo subserver $ httpVersion req)
|
||||
route (Proxy :: Proxy api) (passToServer subserver $ httpVersion req)
|
||||
|
||||
pathIsEmpty :: Request -> Bool
|
||||
pathIsEmpty = go . pathInfo
|
||||
|
|
|
|||
|
|
@ -1,13 +1,13 @@
|
|||
{-# LANGUAGE DeriveFunctor #-}
|
||||
|
||||
{-# LANGUAGE CPP #-}
|
||||
module Servant.Server.Internal.Router where
|
||||
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as M
|
||||
import Data.Monoid ((<>))
|
||||
import Data.Text (Text)
|
||||
import Network.Wai (Request, Response, pathInfo)
|
||||
import Servant.Server.Internal.RoutingApplication
|
||||
import Servant.Server.Internal.ServantErr
|
||||
|
||||
type Router = Router' RoutingApplication
|
||||
|
||||
|
|
@ -63,17 +63,31 @@ 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 $ Fail 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 $ Fail 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)
|
||||
else respond mResponse1
|
||||
runRouter r1 request $ \ mResponse1 -> case mResponse1 of
|
||||
Fail _ -> runRouter r2 request $ \ mResponse2 ->
|
||||
respond (highestPri mResponse1 mResponse2)
|
||||
_ -> respond mResponse1
|
||||
where
|
||||
highestPri (Fail e1) (Fail e2) =
|
||||
if worseHTTPCode (errHTTPCode e1) (errHTTPCode e2)
|
||||
then Fail e2
|
||||
else Fail e1
|
||||
highestPri (Fail _) y = y
|
||||
highestPri x _ = x
|
||||
|
||||
|
||||
-- Priority on HTTP codes.
|
||||
--
|
||||
-- It just so happens that 404 < 405 < 406 as far as
|
||||
-- we are concerned here, so we can use (<).
|
||||
worseHTTPCode :: Int -> Int -> Bool
|
||||
worseHTTPCode = (<)
|
||||
|
|
|
|||
|
|
@ -1,68 +1,37 @@
|
|||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE DeriveFunctor #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
module Servant.Server.Internal.RoutingApplication where
|
||||
|
||||
#if !MIN_VERSION_base(4,8,0)
|
||||
import Control.Applicative (Applicative, (<$>))
|
||||
import Data.Monoid (Monoid, mappend, mempty)
|
||||
import Control.Applicative ((<$>))
|
||||
#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
|
||||
|
||||
type RoutingApplication =
|
||||
Request -- ^ the request, the field 'pathInfo' may be modified by url routing
|
||||
-> (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
|
||||
-- | The result of matching against a path in the route tree.
|
||||
data RouteResult a =
|
||||
Fail ServantErr -- ^ Keep trying other paths. The @ServantErr@
|
||||
-- should only be 404, 405 or 406.
|
||||
| FailFatal !ServantErr -- ^ Don't try other paths.
|
||||
| Route !a
|
||||
deriving (Eq, Show, Read, Functor)
|
||||
|
||||
data ReqBodyState = Uncalled
|
||||
| Called !B.ByteString
|
||||
|
|
@ -91,55 +60,190 @@ 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 (Fail err) = respond $ responseServantErr err
|
||||
routingRespond (FailFatal err) = respond $ responseServantErr err
|
||||
routingRespond (Route v) = respond v
|
||||
|
||||
runAction :: IO (RouteResult (ExceptT ServantErr IO a))
|
||||
-- We currently mix up the order in which we perform checks
|
||||
-- and the priority with which errors are reported.
|
||||
--
|
||||
-- For example, we perform Capture checks prior to method checks,
|
||||
-- and therefore get 404 before 405.
|
||||
--
|
||||
-- However, we also perform body checks prior to method checks
|
||||
-- now, and therefore get 415 before 405, which is wrong.
|
||||
--
|
||||
-- If we delay Captures, but perform method checks eagerly, we
|
||||
-- end up potentially preferring 405 over 404, whcih is also bad.
|
||||
--
|
||||
-- So in principle, we'd like:
|
||||
--
|
||||
-- static routes (can cause 404)
|
||||
-- delayed captures (can cause 404)
|
||||
-- methods (can cause 405)
|
||||
-- delayed body (can cause 415, 400)
|
||||
-- accept header (can cause 406)
|
||||
--
|
||||
-- According to the HTTP decision diagram, the priority order
|
||||
-- between HTTP status codes is as follows:
|
||||
--
|
||||
|
||||
-- | A 'Delayed' is a representation of a handler with scheduled
|
||||
-- delayed checks that can trigger errors.
|
||||
--
|
||||
-- Why would we want to delay checks?
|
||||
--
|
||||
-- There are two reasons:
|
||||
--
|
||||
-- 1. Currently, the order in which we perform checks coincides
|
||||
-- with the error we will generate. This is because during checks,
|
||||
-- once an error occurs, we do not perform any subsequent checks,
|
||||
-- but rather return this error.
|
||||
--
|
||||
-- This is not a necessity: we could continue doing other checks,
|
||||
-- and choose the preferred error. However, that would in general
|
||||
-- mean more checking, which leads us to the other reason.
|
||||
--
|
||||
-- 2. We really want to avoid doing certain checks too early. For
|
||||
-- example, captures involve parsing, and are much more costly
|
||||
-- than static route matches. In particular, if several paths
|
||||
-- contain the "same" capture, we'd like as much as possible to
|
||||
-- avoid trying the same parse many times. Also tricky is the
|
||||
-- request body. Again, this involves parsing, but also, WAI makes
|
||||
-- obtaining the request body a side-effecting operation. We
|
||||
-- could/can work around this by manually caching the request body,
|
||||
-- but we'd rather keep the number of times we actually try to
|
||||
-- decode the request body to an absolute minimum.
|
||||
--
|
||||
-- We prefer to have the following relative priorities of error
|
||||
-- codes:
|
||||
--
|
||||
-- @
|
||||
-- 404
|
||||
-- 405 (bad method)
|
||||
-- 401 (unauthorized)
|
||||
-- 415 (unsupported media type)
|
||||
-- 400 (bad request)
|
||||
-- 406 (not acceptable)
|
||||
-- @
|
||||
--
|
||||
-- Therefore, while routing, we delay most checks so that they
|
||||
-- will ultimately occur in the right order.
|
||||
--
|
||||
-- A 'Delayed' contains three delayed blocks of tests, and
|
||||
-- the actual handler:
|
||||
--
|
||||
-- 1. Delayed captures. These can actually cause 404, and
|
||||
-- while they're costly, they should be done first among the
|
||||
-- delayed checks (at least as long as we do not decouple the
|
||||
-- check order from the error reporting, see above). Delayed
|
||||
-- captures can provide inputs to the actual handler.
|
||||
--
|
||||
-- 2. Method check(s). This can cause a 405. On success,
|
||||
-- it does not provide an input for the handler. Method checks
|
||||
-- are comparatively cheap.
|
||||
--
|
||||
-- 3. Body and accept header checks. The request body check can
|
||||
-- cause both 400 and 415. This provides an input to the handler.
|
||||
-- The accept header check can be performed as the final
|
||||
-- computation in this block. It can cause a 406.
|
||||
--
|
||||
data Delayed :: * -> * where
|
||||
Delayed :: IO (RouteResult a)
|
||||
-> IO (RouteResult ())
|
||||
-> IO (RouteResult b)
|
||||
-> (a -> b -> RouteResult c)
|
||||
-> Delayed c
|
||||
|
||||
instance Functor Delayed where
|
||||
fmap f (Delayed a b c g) = Delayed a b c ((fmap.fmap.fmap) f g)
|
||||
|
||||
-- | Add a capture to the end of the capture block.
|
||||
addCapture :: Delayed (a -> b)
|
||||
-> IO (RouteResult a)
|
||||
-> Delayed b
|
||||
addCapture (Delayed captures method body server) new =
|
||||
Delayed (combineRouteResults (,) captures new) method body (\ (x, v) y -> ($ v) <$> server x y)
|
||||
|
||||
-- | Add a method check to the end of the method block.
|
||||
addMethodCheck :: Delayed a
|
||||
-> IO (RouteResult ())
|
||||
-> Delayed a
|
||||
addMethodCheck (Delayed captures method body server) new =
|
||||
Delayed captures (combineRouteResults const method new) body server
|
||||
|
||||
-- | Add a body check to the end of the body block.
|
||||
addBodyCheck :: Delayed (a -> b)
|
||||
-> IO (RouteResult a)
|
||||
-> Delayed b
|
||||
addBodyCheck (Delayed captures method body server) new =
|
||||
Delayed captures method (combineRouteResults (,) body new) (\ x (y, v) -> ($ v) <$> server x y)
|
||||
|
||||
-- | Add an accept header check to the end of the body block.
|
||||
-- The accept header check should occur after the body check,
|
||||
-- but this will be the case, because the accept header check
|
||||
-- is only scheduled by the method combinators.
|
||||
addAcceptCheck :: Delayed a
|
||||
-> IO (RouteResult ())
|
||||
-> Delayed a
|
||||
addAcceptCheck (Delayed captures method body server) new =
|
||||
Delayed captures method (combineRouteResults const body new) server
|
||||
|
||||
-- | Many combinators extract information that is passed to
|
||||
-- the handler without the possibility of failure. In such a
|
||||
-- case, 'passToServer' can be used.
|
||||
passToServer :: Delayed (a -> b) -> a -> Delayed b
|
||||
passToServer d x = ($ x) <$> d
|
||||
|
||||
-- | The combination 'IO . RouteResult' is a monad, but we
|
||||
-- don't explicitly wrap it in a newtype in order to make it
|
||||
-- an instance. This is the '>>=' of that monad.
|
||||
--
|
||||
-- We stop on the first error.
|
||||
bindRouteResults :: IO (RouteResult a) -> (a -> IO (RouteResult b)) -> IO (RouteResult b)
|
||||
bindRouteResults m f = do
|
||||
r <- m
|
||||
case r of
|
||||
Fail e -> return $ Fail e
|
||||
FailFatal e -> return $ FailFatal e
|
||||
Route a -> f a
|
||||
|
||||
-- | Common special case of 'bindRouteResults', corresponding
|
||||
-- to 'liftM2'.
|
||||
combineRouteResults :: (a -> b -> c) -> IO (RouteResult a) -> IO (RouteResult b) -> IO (RouteResult c)
|
||||
combineRouteResults f m1 m2 =
|
||||
m1 `bindRouteResults` \ a ->
|
||||
m2 `bindRouteResults` \ b ->
|
||||
return (Route (f a b))
|
||||
|
||||
-- | Run a delayed server. Performs all scheduled operations
|
||||
-- in order, and passes the results from the capture and body
|
||||
-- blocks on to the actual handler.
|
||||
runDelayed :: Delayed a
|
||||
-> IO (RouteResult a)
|
||||
runDelayed (Delayed captures method body server) =
|
||||
captures `bindRouteResults` \ c ->
|
||||
method `bindRouteResults` \ _ ->
|
||||
body `bindRouteResults` \ b ->
|
||||
return (server c b)
|
||||
|
||||
-- | Runs a delayed server and the resulting action.
|
||||
-- Takes a continuation that lets us send a response.
|
||||
-- Also takes a continuation for how to turn the
|
||||
-- result of the delayed server into a response.
|
||||
runAction :: Delayed (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 = runDelayed action >>= go >>= respond
|
||||
where
|
||||
go (RR (Right a)) = do
|
||||
go (Fail e) = return $ Fail e
|
||||
go (FailFatal e) = return $ FailFatal e
|
||||
go (Route 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
|
||||
|
||||
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)
|
||||
|
||||
extractR :: RouteResult (a :<|> b) -> RouteResult b
|
||||
extractR (RR (Right (_ :<|> b))) = RR (Right b)
|
||||
extractR (RR (Left err)) = RR (Left err)
|
||||
|
||||
failWith :: RouteMismatch -> RouteResult a
|
||||
failWith = RR . Left
|
||||
|
||||
succeedWith :: a -> RouteResult a
|
||||
succeedWith = RR . Right
|
||||
|
||||
isMismatch :: RouteResult a -> Bool
|
||||
isMismatch (RR (Left _)) = True
|
||||
isMismatch _ = False
|
||||
|
||||
case e of
|
||||
Left err -> return . Route $ responseServantErr err
|
||||
Right x -> return $! k x
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
224
servant-server/test/Servant/Server/ErrorSpec.hs
Normal file
224
servant-server/test/Servant/Server/ErrorSpec.hs
Normal file
|
|
@ -0,0 +1,224 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
module Servant.Server.ErrorSpec (spec) where
|
||||
|
||||
import Control.Monad.Trans.Except (throwE)
|
||||
import Data.Aeson (encode)
|
||||
import qualified Data.ByteString.Char8 as BC
|
||||
import qualified Data.ByteString.Lazy.Char8 as BCL
|
||||
import Data.Proxy
|
||||
import Network.HTTP.Types (hAccept, hContentType, methodGet,
|
||||
methodPost, methodPut)
|
||||
import Safe (readMay)
|
||||
import Test.Hspec
|
||||
import Test.Hspec.Wai
|
||||
|
||||
import Servant
|
||||
|
||||
spec :: Spec
|
||||
spec = describe "HTTP Errors" $ do
|
||||
errorOrderSpec
|
||||
prioErrorsSpec
|
||||
errorRetrySpec
|
||||
errorChoiceSpec
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- * Error Order {{{
|
||||
|
||||
type ErrorOrderApi = "home"
|
||||
:> ReqBody '[JSON] Int
|
||||
:> Capture "t" Int
|
||||
:> Post '[JSON] Int
|
||||
|
||||
|
||||
errorOrderApi :: Proxy ErrorOrderApi
|
||||
errorOrderApi = Proxy
|
||||
|
||||
errorOrderServer :: Server ErrorOrderApi
|
||||
errorOrderServer = \_ _ -> throwE err402
|
||||
|
||||
errorOrderSpec :: Spec
|
||||
errorOrderSpec = describe "HTTP error order"
|
||||
$ with (return $ serve errorOrderApi errorOrderServer) $ do
|
||||
let badContentType = (hContentType, "text/plain")
|
||||
badAccept = (hAccept, "text/plain")
|
||||
badMethod = methodGet
|
||||
badUrl = "home/nonexistent"
|
||||
badBody = "nonsense"
|
||||
goodContentType = (hContentType, "application/json")
|
||||
goodAccept = (hAccept, "application/json")
|
||||
goodMethod = methodPost
|
||||
goodUrl = "home/2"
|
||||
goodBody = encode (5 :: Int)
|
||||
|
||||
it "has 404 as its highest priority error" $ do
|
||||
request badMethod badUrl [badContentType, badAccept] badBody
|
||||
`shouldRespondWith` 404
|
||||
|
||||
it "has 405 as its second highest priority error" $ do
|
||||
request badMethod goodUrl [badContentType, badAccept] badBody
|
||||
`shouldRespondWith` 405
|
||||
|
||||
it "has 415 as its third highest priority error" $ do
|
||||
request goodMethod goodUrl [badContentType, badAccept] badBody
|
||||
`shouldRespondWith` 415
|
||||
|
||||
it "has 400 as its fourth highest priority error" $ do
|
||||
request goodMethod goodUrl [goodContentType, badAccept] badBody
|
||||
`shouldRespondWith` 400
|
||||
|
||||
it "has 406 as its fifth highest priority error" $ do
|
||||
request goodMethod goodUrl [goodContentType, badAccept] goodBody
|
||||
`shouldRespondWith` 406
|
||||
|
||||
it "has handler-level errors as last priority" $ do
|
||||
request goodMethod goodUrl [goodContentType, goodAccept] goodBody
|
||||
`shouldRespondWith` 402
|
||||
|
||||
type PrioErrorsApi = ReqBody '[JSON] Integer :> "foo" :> Get '[JSON] Integer
|
||||
|
||||
prioErrorsApi :: Proxy PrioErrorsApi
|
||||
prioErrorsApi = Proxy
|
||||
|
||||
-- Check whether matching continues even if a 'ReqBody' or similar construct
|
||||
-- is encountered early in a path. We don't want to see a complaint about the
|
||||
-- request body unless the path actually matches.
|
||||
prioErrorsSpec :: Spec
|
||||
prioErrorsSpec = describe "PrioErrors" $ do
|
||||
let server = return
|
||||
with (return $ serve prioErrorsApi server) $ do
|
||||
let check (mdescr, method) path (cdescr, ctype, body) resp =
|
||||
it fulldescr $
|
||||
Test.Hspec.Wai.request method path [(hContentType, ctype)] body
|
||||
`shouldRespondWith` resp
|
||||
where
|
||||
fulldescr = "returns " ++ show (matchStatus resp) ++ " on " ++ mdescr
|
||||
++ " " ++ BC.unpack path ++ " (" ++ cdescr ++ ")"
|
||||
|
||||
get' = ("GET", methodGet)
|
||||
put' = ("PUT", methodPut)
|
||||
|
||||
txt = ("text" , "text/plain;charset=utf8" , "42" )
|
||||
ijson = ("invalid json", "application/json;charset=utf8", "invalid" )
|
||||
vjson = ("valid json" , "application/json;charset=utf8", encode (5 :: Int))
|
||||
|
||||
check get' "/" txt 404
|
||||
check get' "/bar" txt 404
|
||||
check get' "/foo" txt 415
|
||||
check put' "/" txt 404
|
||||
check put' "/bar" txt 404
|
||||
check put' "/foo" txt 405
|
||||
check get' "/" ijson 404
|
||||
check get' "/bar" ijson 404
|
||||
check get' "/foo" ijson 400
|
||||
check put' "/" ijson 404
|
||||
check put' "/bar" ijson 404
|
||||
check put' "/foo" ijson 405
|
||||
check get' "/" vjson 404
|
||||
check get' "/bar" vjson 404
|
||||
check get' "/foo" vjson 200
|
||||
check put' "/" vjson 404
|
||||
check put' "/bar" vjson 404
|
||||
check put' "/foo" vjson 405
|
||||
|
||||
-- }}}
|
||||
------------------------------------------------------------------------------
|
||||
-- * Error Retry {{{
|
||||
|
||||
type ErrorRetryApi
|
||||
= "a" :> ReqBody '[JSON] Int :> Post '[JSON] Int -- err402
|
||||
:<|> "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 '[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
|
||||
|
||||
errorRetryServer :: Server ErrorRetryApi
|
||||
errorRetryServer
|
||||
= (\_ -> throwE err402)
|
||||
:<|> (\_ -> return 1)
|
||||
:<|> (\_ -> return 2)
|
||||
:<|> (\_ -> return 3)
|
||||
:<|> (\_ -> return 4)
|
||||
:<|> (\_ -> return 5)
|
||||
:<|> (\_ -> return 6)
|
||||
:<|> (\_ -> return 7)
|
||||
|
||||
errorRetrySpec :: Spec
|
||||
errorRetrySpec = describe "Handler search"
|
||||
$ with (return $ serve errorRetryApi errorRetryServer) $ do
|
||||
|
||||
let 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 (7 :: Int) }
|
||||
|
||||
it "should continue when methods don't match" $ do
|
||||
request methodGet "a" [jsonCT, jsonAccept] jsonBody
|
||||
`shouldRespondWith` 200 { matchBody = Just $ encode (4 :: Int) }
|
||||
|
||||
-- }}}
|
||||
------------------------------------------------------------------------------
|
||||
-- * 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, "blah")] "5"
|
||||
`shouldRespondWith` 406
|
||||
|
||||
|
||||
-- }}}
|
||||
------------------------------------------------------------------------------
|
||||
-- * Instances {{{
|
||||
|
||||
instance MimeUnrender PlainText Int where
|
||||
mimeUnrender _ x = maybe (Left "no parse") Right (readMay $ BCL.unpack x)
|
||||
|
||||
instance MimeRender PlainText Int where
|
||||
mimeRender _ = BCL.pack . show
|
||||
-- }}}
|
||||
|
|
@ -1,6 +1,7 @@
|
|||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
|
@ -17,7 +18,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,18 +26,13 @@ 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)
|
||||
import Network.Wai.Internal (Response(ResponseBuilder))
|
||||
import Network.Wai.Test (defaultRequest, request,
|
||||
runSession, simpleBody)
|
||||
import Test.Hspec (Spec, describe, it, shouldBe)
|
||||
import Test.Hspec.Wai (get, liftIO, matchHeaders,
|
||||
matchStatus, post, request,
|
||||
shouldRespondWith, with, (<:>))
|
||||
import Servant.API ((:<|>) (..), (:>), Capture, Delete,
|
||||
Get, Header (..), Headers,
|
||||
HttpVersion, IsSecure (..), JSON,
|
||||
|
|
@ -46,12 +41,14 @@ import Servant.API ((:<|>) (..), (:>), Capture, Delete,
|
|||
Raw, RemoteHost, ReqBody,
|
||||
addHeader)
|
||||
import Servant.Server (Server, serve, ServantErr(..), err404)
|
||||
import Test.Hspec (Spec, describe, it, shouldBe)
|
||||
import Test.Hspec.Wai (get, liftIO, matchHeaders,
|
||||
matchStatus, post, request,
|
||||
shouldRespondWith, with, (<:>))
|
||||
import Servant.Server.Internal.RoutingApplication (toApplication, RouteResult(..))
|
||||
import Servant.Server.Internal.Router
|
||||
(tweakResponse, runRouter,
|
||||
Router, Router'(LeafRouter))
|
||||
import Servant.Server.Internal.RoutingApplication
|
||||
(RouteResult(..), RouteMismatch(..),
|
||||
toApplication)
|
||||
|
||||
|
||||
-- * test data types
|
||||
|
|
@ -98,8 +95,6 @@ spec = do
|
|||
headerSpec
|
||||
rawSpec
|
||||
unionSpec
|
||||
prioErrorsSpec
|
||||
errorsSpec
|
||||
routerSpec
|
||||
responseHeadersSpec
|
||||
miscReqCombinatorsSpec
|
||||
|
|
@ -158,9 +153,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 +181,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
|
||||
|
|
@ -264,13 +259,13 @@ queryParamSpec = do
|
|||
}
|
||||
|
||||
let params3'' = "?unknown="
|
||||
response3' <- Network.Wai.Test.request defaultRequest{
|
||||
response3'' <- Network.Wai.Test.request defaultRequest{
|
||||
rawQueryString = params3'',
|
||||
queryString = parseQuery params3'',
|
||||
pathInfo = ["b"]
|
||||
}
|
||||
liftIO $
|
||||
decode' (simpleBody response3') `shouldBe` Just alice{
|
||||
decode' (simpleBody response3'') `shouldBe` Just alice{
|
||||
name = "Alice"
|
||||
}
|
||||
|
||||
|
|
@ -311,7 +306,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 +348,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 +390,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,104 +519,11 @@ 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
|
||||
|
||||
prioErrorsApi :: Proxy PrioErrorsApi
|
||||
prioErrorsApi = Proxy
|
||||
|
||||
-- | Test the relative priority of error responses from the server.
|
||||
--
|
||||
-- In particular, we check whether matching continues even if a 'ReqBody'
|
||||
-- or similar construct is encountered early in a path. We don't want to
|
||||
-- see a complaint about the request body unless the path actually matches.
|
||||
--
|
||||
prioErrorsSpec :: Spec
|
||||
prioErrorsSpec = describe "PrioErrors" $ do
|
||||
let server = return . age
|
||||
with (return $ serve prioErrorsApi server) $ do
|
||||
let check (mdescr, method) path (cdescr, ctype, body) resp =
|
||||
it fulldescr $
|
||||
Test.Hspec.Wai.request method path [(hContentType, ctype)] body
|
||||
`shouldRespondWith` resp
|
||||
where
|
||||
fulldescr = "returns " ++ show (matchStatus resp) ++ " on " ++ mdescr
|
||||
++ " " ++ cs path ++ " (" ++ cdescr ++ ")"
|
||||
|
||||
get' = ("GET", methodGet)
|
||||
put' = ("PUT", methodPut)
|
||||
|
||||
txt = ("text" , "text/plain;charset=utf8" , "42" )
|
||||
ijson = ("invalid json", "application/json;charset=utf8", "invalid" )
|
||||
vjson = ("valid json" , "application/json;charset=utf8", encode alice)
|
||||
|
||||
check get' "/" txt 404
|
||||
check get' "/bar" txt 404
|
||||
check get' "/foo" txt 415
|
||||
check put' "/" txt 404
|
||||
check put' "/bar" txt 404
|
||||
check put' "/foo" txt 405
|
||||
check get' "/" ijson 404
|
||||
check get' "/bar" ijson 404
|
||||
check get' "/foo" ijson 400
|
||||
check put' "/" ijson 404
|
||||
check put' "/bar" ijson 404
|
||||
check put' "/foo" ijson 405
|
||||
check get' "/" vjson 404
|
||||
check get' "/bar" vjson 404
|
||||
check get' "/foo" vjson 200
|
||||
check put' "/" vjson 404
|
||||
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
|
||||
|
|
@ -631,7 +533,7 @@ routerSpec = do
|
|||
|
||||
router', router :: Router
|
||||
router' = tweakResponse (twk <$>) router
|
||||
router = LeafRouter $ \_ cont -> cont (RR . Right $ responseBuilder (Status 201 "") [] "")
|
||||
router = LeafRouter $ \_ cont -> cont (Route $ responseBuilder (Status 201 "") [] "")
|
||||
|
||||
twk :: Response -> Response
|
||||
twk (ResponseBuilder (Status i s) hs b) = ResponseBuilder (Status (i + 1) s) hs b
|
||||
|
|
|
|||
|
|
@ -6,6 +6,7 @@ HEAD
|
|||
* Add more instances for (:<|>)
|
||||
* Use `http-api-data` instead of `Servant.Common.Text`
|
||||
* Remove matrix params.
|
||||
* Add PlainText String MimeRender and MimeUnrender instances.
|
||||
|
||||
0.4.2
|
||||
-----
|
||||
|
|
|
|||
|
|
@ -57,12 +57,14 @@ module Servant.API.ContentTypes
|
|||
, AcceptHeader(..)
|
||||
, AllCTRender(..)
|
||||
, AllCTUnrender(..)
|
||||
, AllMime(..)
|
||||
, AllMimeRender(..)
|
||||
, AllMimeUnrender(..)
|
||||
, FromFormUrlEncoded(..)
|
||||
, ToFormUrlEncoded(..)
|
||||
, IsNonEmpty
|
||||
, eitherDecodeLenient
|
||||
, canHandleAcceptH
|
||||
) where
|
||||
|
||||
#if !MIN_VERSION_base(4,8,0)
|
||||
|
|
@ -80,6 +82,8 @@ import qualified Data.ByteString as BS
|
|||
import Data.ByteString.Lazy (ByteString, fromStrict,
|
||||
toStrict)
|
||||
import qualified Data.ByteString.Lazy as B
|
||||
import qualified Data.ByteString.Lazy.Char8 as BC
|
||||
import Data.Maybe (isJust)
|
||||
import Data.Monoid
|
||||
import Data.String.Conversions (cs)
|
||||
import qualified Data.Text as TextS
|
||||
|
|
@ -155,14 +159,13 @@ newtype AcceptHeader = AcceptHeader BS.ByteString
|
|||
class Accept ctype => MimeRender ctype a where
|
||||
mimeRender :: Proxy ctype -> a -> ByteString
|
||||
|
||||
class AllCTRender (list :: [*]) a where
|
||||
class (AllMimeRender list a) => AllCTRender (list :: [*]) a where
|
||||
-- If the Accept header can be matched, returns (Just) a tuple of the
|
||||
-- Content-Type and response (serialization of @a@ into the appropriate
|
||||
-- mimetype).
|
||||
handleAcceptH :: Proxy list -> AcceptHeader -> a -> Maybe (ByteString, ByteString)
|
||||
|
||||
instance ( AllMimeRender ctyps a, IsNonEmpty ctyps
|
||||
) => AllCTRender ctyps a where
|
||||
instance (AllMimeRender ctyps a, IsNonEmpty ctyps) => AllCTRender ctyps a where
|
||||
handleAcceptH _ (AcceptHeader accept) val = M.mapAcceptMedia lkup accept
|
||||
where pctyps = Proxy :: Proxy ctyps
|
||||
amrs = allMimeRender pctyps val
|
||||
|
|
@ -210,11 +213,24 @@ instance ( AllMimeUnrender ctyps a, IsNonEmpty ctyps
|
|||
--------------------------------------------------------------------------
|
||||
-- * Utils (Internal)
|
||||
|
||||
class AllMime (list :: [*]) where
|
||||
allMime :: Proxy list -> [M.MediaType]
|
||||
|
||||
instance AllMime '[] where
|
||||
allMime _ = []
|
||||
|
||||
instance (Accept ctyp, AllMime ctyps) => AllMime (ctyp ': ctyps) where
|
||||
allMime _ = (contentType pctyp):allMime pctyps
|
||||
where pctyp = Proxy :: Proxy ctyp
|
||||
pctyps = Proxy :: Proxy ctyps
|
||||
|
||||
canHandleAcceptH :: AllMime list => Proxy list -> AcceptHeader -> Bool
|
||||
canHandleAcceptH p (AcceptHeader h ) = isJust $ M.matchAccept (allMime p) h
|
||||
|
||||
--------------------------------------------------------------------------
|
||||
-- Check that all elements of list are instances of MimeRender
|
||||
--------------------------------------------------------------------------
|
||||
class AllMimeRender (list :: [*]) a where
|
||||
class (AllMime list) => AllMimeRender (list :: [*]) a where
|
||||
allMimeRender :: Proxy list
|
||||
-> a -- value to serialize
|
||||
-> [(M.MediaType, ByteString)] -- content-types/response pairs
|
||||
|
|
@ -238,7 +254,7 @@ instance AllMimeRender '[] a where
|
|||
--------------------------------------------------------------------------
|
||||
-- Check that all elements of list are instances of MimeUnrender
|
||||
--------------------------------------------------------------------------
|
||||
class AllMimeUnrender (list :: [*]) a where
|
||||
class (AllMime list) => AllMimeUnrender (list :: [*]) a where
|
||||
allMimeUnrender :: Proxy list
|
||||
-> ByteString
|
||||
-> [(M.MediaType, Either String a)]
|
||||
|
|
@ -279,6 +295,10 @@ instance MimeRender PlainText TextL.Text where
|
|||
instance MimeRender PlainText TextS.Text where
|
||||
mimeRender _ = fromStrict . TextS.encodeUtf8
|
||||
|
||||
-- | @BC.pack@
|
||||
instance MimeRender PlainText String where
|
||||
mimeRender _ = BC.pack
|
||||
|
||||
-- | @id@
|
||||
instance MimeRender OctetStream ByteString where
|
||||
mimeRender _ = id
|
||||
|
|
@ -328,6 +348,10 @@ instance MimeUnrender PlainText TextL.Text where
|
|||
instance MimeUnrender PlainText TextS.Text where
|
||||
mimeUnrender _ = left show . TextS.decodeUtf8' . toStrict
|
||||
|
||||
-- | @Right . BC.unpack@
|
||||
instance MimeUnrender PlainText String where
|
||||
mimeUnrender _ = Right . BC.unpack
|
||||
|
||||
-- | @Right . id@
|
||||
instance MimeUnrender OctetStream ByteString where
|
||||
mimeUnrender _ = Right . id
|
||||
|
|
|
|||
|
|
@ -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 a new issue