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

Merge pull request #218 from haskell-servant/jkarni/http-errors

Browse source 
Fix error priority and retries
This commit is contained in:
Julian Arni 2015-10-26 17:17:38 +01:00
commit 6a4c967590
14 changed files with 635 additions and 342 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

53
servant-docs/src/Servant/Docs/Internal.hs
View file

@ -496,19 +496,6 @@ sampleByteStrings ctypes@Proxy Proxy =
enc (t, s) = uncurry (t,,) <$> allMimeRender ctypes s enc (t, s) = uncurry (t,,) <$> allMimeRender ctypes s
in concatMap enc samples' 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 -- | The class that helps us automatically get documentation
-- for GET parameters. -- for GET parameters.
-- --
@ -709,14 +696,14 @@ instance
#if MIN_VERSION_base(4,8,0) #if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLe #-} {-# OVERLAPPABLe #-}
#endif #endif
(ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts) (ToSample a, IsNonEmpty cts, AllMimeRender cts a)
=> HasDocs (Delete cts a) where => HasDocs (Delete cts a) where
docsFor Proxy (endpoint, action) DocOptions{..} = docsFor Proxy (endpoint, action) DocOptions{..} =
single endpoint' action' single endpoint' action'
where endpoint' = endpoint & method .~ DocDELETE where endpoint' = endpoint & method .~ DocDELETE
action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p) action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
& response.respTypes .~ supportedTypes t & response.respTypes .~ allMime t
t = Proxy :: Proxy cts t = Proxy :: Proxy cts
p = Proxy :: Proxy a p = Proxy :: Proxy a
@ -724,7 +711,7 @@ instance
#if MIN_VERSION_base(4,8,0) #if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-} {-# OVERLAPPING #-}
#endif #endif
(ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts (ToSample a, IsNonEmpty cts, AllMimeRender cts a
, AllHeaderSamples ls , GetHeaders (HList ls) ) , AllHeaderSamples ls , GetHeaders (HList ls) )
=> HasDocs (Delete cts (Headers ls a)) where => HasDocs (Delete cts (Headers ls a)) where
docsFor Proxy (endpoint, action) DocOptions{..} = docsFor Proxy (endpoint, action) DocOptions{..} =
@ -733,7 +720,7 @@ instance
where hdrs = allHeaderToSample (Proxy :: Proxy ls) where hdrs = allHeaderToSample (Proxy :: Proxy ls)
endpoint' = endpoint & method .~ DocDELETE endpoint' = endpoint & method .~ DocDELETE
action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p) action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
& response.respTypes .~ supportedTypes t & response.respTypes .~ allMime t
& response.respHeaders .~ hdrs & response.respHeaders .~ hdrs
t = Proxy :: Proxy cts t = Proxy :: Proxy cts
p = Proxy :: Proxy a p = Proxy :: Proxy a
@ -742,14 +729,14 @@ instance
#if MIN_VERSION_base(4,8,0) #if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLe #-} {-# OVERLAPPABLe #-}
#endif #endif
(ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts) (ToSample a, IsNonEmpty cts, AllMimeRender cts a)
=> HasDocs (Get cts a) where => HasDocs (Get cts a) where
docsFor Proxy (endpoint, action) DocOptions{..} = docsFor Proxy (endpoint, action) DocOptions{..} =
single endpoint' action' single endpoint' action'
where endpoint' = endpoint & method .~ DocGET where endpoint' = endpoint & method .~ DocGET
action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p) action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
& response.respTypes .~ supportedTypes t & response.respTypes .~ allMime t
t = Proxy :: Proxy cts t = Proxy :: Proxy cts
p = Proxy :: Proxy a p = Proxy :: Proxy a
@ -757,7 +744,7 @@ instance
#if MIN_VERSION_base(4,8,0) #if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-} {-# OVERLAPPING #-}
#endif #endif
(ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts (ToSample a, IsNonEmpty cts, AllMimeRender cts a
, AllHeaderSamples ls , GetHeaders (HList ls) ) , AllHeaderSamples ls , GetHeaders (HList ls) )
=> HasDocs (Get cts (Headers ls a)) where => HasDocs (Get cts (Headers ls a)) where
docsFor Proxy (endpoint, action) DocOptions{..} = docsFor Proxy (endpoint, action) DocOptions{..} =
@ -766,7 +753,7 @@ instance
where hdrs = allHeaderToSample (Proxy :: Proxy ls) where hdrs = allHeaderToSample (Proxy :: Proxy ls)
endpoint' = endpoint & method .~ DocGET endpoint' = endpoint & method .~ DocGET
action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p) action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
& response.respTypes .~ supportedTypes t & response.respTypes .~ allMime t
& response.respHeaders .~ hdrs & response.respHeaders .~ hdrs
t = Proxy :: Proxy cts t = Proxy :: Proxy cts
p = Proxy :: Proxy a p = Proxy :: Proxy a
@ -784,14 +771,14 @@ instance
#if MIN_VERSION_base(4,8,0) #if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLE #-} {-# OVERLAPPABLE #-}
#endif #endif
(ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts) (ToSample a, IsNonEmpty cts, AllMimeRender cts a)
=> HasDocs (Post cts a) where => HasDocs (Post cts a) where
docsFor Proxy (endpoint, action) DocOptions{..} = docsFor Proxy (endpoint, action) DocOptions{..} =
single endpoint' action' single endpoint' action'
where endpoint' = endpoint & method .~ DocPOST where endpoint' = endpoint & method .~ DocPOST
action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p) action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
& response.respTypes .~ supportedTypes t & response.respTypes .~ allMime t
& response.respStatus .~ 201 & response.respStatus .~ 201
t = Proxy :: Proxy cts t = Proxy :: Proxy cts
p = Proxy :: Proxy a p = Proxy :: Proxy a
@ -800,7 +787,7 @@ instance
#if MIN_VERSION_base(4,8,0) #if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-} {-# OVERLAPPING #-}
#endif #endif
(ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts (ToSample a, IsNonEmpty cts, AllMimeRender cts a
, AllHeaderSamples ls , GetHeaders (HList ls) ) , AllHeaderSamples ls , GetHeaders (HList ls) )
=> HasDocs (Post cts (Headers ls a)) where => HasDocs (Post cts (Headers ls a)) where
docsFor Proxy (endpoint, action) DocOptions{..} = docsFor Proxy (endpoint, action) DocOptions{..} =
@ -809,7 +796,7 @@ instance
where hdrs = allHeaderToSample (Proxy :: Proxy ls) where hdrs = allHeaderToSample (Proxy :: Proxy ls)
endpoint' = endpoint & method .~ DocPOST endpoint' = endpoint & method .~ DocPOST
action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p) action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
& response.respTypes .~ supportedTypes t & response.respTypes .~ allMime t
& response.respStatus .~ 201 & response.respStatus .~ 201
& response.respHeaders .~ hdrs & response.respHeaders .~ hdrs
t = Proxy :: Proxy cts t = Proxy :: Proxy cts
@ -819,14 +806,14 @@ instance
#if MIN_VERSION_base(4,8,0) #if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLE #-} {-# OVERLAPPABLE #-}
#endif #endif
(ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts) (ToSample a, IsNonEmpty cts, AllMimeRender cts a)
=> HasDocs (Put cts a) where => HasDocs (Put cts a) where
docsFor Proxy (endpoint, action) DocOptions{..} = docsFor Proxy (endpoint, action) DocOptions{..} =
single endpoint' action' single endpoint' action'
where endpoint' = endpoint & method .~ DocPUT where endpoint' = endpoint & method .~ DocPUT
action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p) action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
& response.respTypes .~ supportedTypes t & response.respTypes .~ allMime t
& response.respStatus .~ 200 & response.respStatus .~ 200
t = Proxy :: Proxy cts t = Proxy :: Proxy cts
p = Proxy :: Proxy a p = Proxy :: Proxy a
@ -835,8 +822,8 @@ instance
#if MIN_VERSION_base(4,8,0) #if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-} {-# OVERLAPPING #-}
#endif #endif
(ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts ( ToSample a, IsNonEmpty cts, AllMimeRender cts a,
, AllHeaderSamples ls , GetHeaders (HList ls) ) AllHeaderSamples ls , GetHeaders (HList ls) )
=> HasDocs (Put cts (Headers ls a)) where => HasDocs (Put cts (Headers ls a)) where
docsFor Proxy (endpoint, action) DocOptions{..} = docsFor Proxy (endpoint, action) DocOptions{..} =
single endpoint' action' single endpoint' action'
@ -844,7 +831,7 @@ instance
where hdrs = allHeaderToSample (Proxy :: Proxy ls) where hdrs = allHeaderToSample (Proxy :: Proxy ls)
endpoint' = endpoint & method .~ DocPUT endpoint' = endpoint & method .~ DocPUT
action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p) action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)
& response.respTypes .~ supportedTypes t & response.respTypes .~ allMime t
& response.respStatus .~ 200 & response.respStatus .~ 200
& response.respHeaders .~ hdrs & response.respHeaders .~ hdrs
t = Proxy :: Proxy cts 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 -- example data. However, there's no reason to believe that the instances of
-- 'AllMimeUnrender' and 'AllMimeRender' actually agree (or to suppose that -- 'AllMimeUnrender' and 'AllMimeRender' actually agree (or to suppose that
-- both are even defined) for any particular type. -- both are even defined) for any particular type.
instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, HasDocs sublayout instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, HasDocs sublayout)
, SupportedTypes cts)
=> HasDocs (ReqBody cts a :> sublayout) where => HasDocs (ReqBody cts a :> sublayout) where
docsFor Proxy (endpoint, action) = docsFor Proxy (endpoint, action) =
@ -899,7 +885,7 @@ instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, HasDocs sublayout
where sublayoutP = Proxy :: Proxy sublayout where sublayoutP = Proxy :: Proxy sublayout
action' = action & rqbody .~ sampleByteString t p action' = action & rqbody .~ sampleByteString t p
& rqtypes .~ supportedTypes t & rqtypes .~ allMime t
t = Proxy :: Proxy cts t = Proxy :: Proxy cts
p = Proxy :: Proxy a p = Proxy :: Proxy a
@ -957,4 +943,3 @@ instance ToSample a => ToSample (Product a)
instance ToSample a => ToSample (First a) instance ToSample a => ToSample (First a)
instance ToSample a => ToSample (Last a) instance ToSample a => ToSample (Last a)
instance ToSample a => ToSample (Dual a) instance ToSample a => ToSample (Dual a)

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

@ -5,11 +5,11 @@
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
import Data.Aeson import Data.Aeson
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import Data.Text (Text) import Data.Text (Text)
import GHC.Generics import GHC.Generics
import Network.HTTP.Types
import Network.Wai import Network.Wai
import Network.Wai.Handler.Warp import Network.Wai.Handler.Warp
import Servant import Servant
@ -28,15 +28,16 @@ data AuthProtected
instance HasServer rest => HasServer (AuthProtected :> rest) where instance HasServer rest => HasServer (AuthProtected :> rest) where
type ServerT (AuthProtected :> rest) m = ServerT rest m type ServerT (AuthProtected :> rest) m = ServerT rest m
route Proxy a = WithRequest $ \ request -> route Proxy subserver = WithRequest $ \ request ->
route (Proxy :: Proxy rest) $ do route (Proxy :: Proxy rest) $ addAcceptCheck subserver $ cookieCheck request
case lookup "Cookie" (requestHeaders request) of where
Nothing -> return $ failWith $ HttpError status401 (Just "Missing auth header.") cookieCheck req = case lookup "Cookie" (requestHeaders req) of
Just v -> do Nothing -> return $ FailFatal err401 { errBody = "Missing auth header" }
authGranted <- isGoodCookie v Just v -> do
if authGranted authGranted <- isGoodCookie v
then a if authGranted
else return $ failWith $ HttpError status403 (Just "Invalid cookie.") then return $ Route ()
else return $ FailFatal err403 { errBody = "Invalid cookie" }
type PrivateAPI = Get '[JSON] [PrivateData] type PrivateAPI = Get '[JSON] [PrivateData]

3
servant-server/CHANGELOG.md
View file

@ -5,6 +5,9 @@ HEAD
* Drop `EitherT` in favor of `ExceptT` * Drop `EitherT` in favor of `ExceptT`
* Use `http-api-data` instead of `Servant.Common.Text` * Use `http-api-data` instead of `Servant.Common.Text`
* Remove matrix params. * Remove matrix params.
* Remove `RouteMismatch`.
* Redefined constructors of `RouteResult`.
* Added `Delayed` and related functions (`addMethodCheck`, `addAcceptCheck`, `addBodyCheck`, `runDelayed`)
0.4.1 0.4.1
----- -----

2
servant-server/servant-server.cabal
View file

@ -95,6 +95,7 @@ test-suite spec
Servant.Server.Internal.EnterSpec Servant.Server.Internal.EnterSpec
Servant.ServerSpec Servant.ServerSpec
Servant.Utils.StaticFilesSpec Servant.Utils.StaticFilesSpec
Servant.Server.ErrorSpec
build-depends: build-depends:
base == 4.* base == 4.*
, aeson , aeson
@ -108,6 +109,7 @@ test-suite spec
, network >= 2.6 , network >= 2.6
, QuickCheck , QuickCheck
, parsec , parsec
, safe
, servant , servant
, servant-server , servant-server
, string-conversions , string-conversions

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

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

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

@ -1,15 +1,15 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-} {-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
#if !MIN_VERSION_base(4,8,0) #if !MIN_VERSION_base(4,8,0)
{-# LANGUAGE OverlappingInstances #-} {-# LANGUAGE OverlappingInstances #-}
#endif #endif
module Servant.Server.Internal module Servant.Server.Internal
@ -26,9 +26,9 @@ import Control.Monad.Trans.Except (ExceptT)
import qualified Data.ByteString as B import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy as BL
import qualified Data.Map as M import qualified Data.Map as M
import Data.Maybe (mapMaybe, fromMaybe) import Data.Maybe (fromMaybe, mapMaybe)
import Data.String (fromString) import Data.String (fromString)
import Data.String.Conversions (cs, (<>), ConvertibleStrings) import Data.String.Conversions (ConvertibleStrings, cs, (<>))
import Data.Text (Text) import Data.Text (Text)
import Data.Typeable import Data.Typeable
import GHC.TypeLits (KnownSymbol, symbolVal) import GHC.TypeLits (KnownSymbol, symbolVal)
@ -46,9 +46,11 @@ import Servant.API ((:<|>) (..), (:>), Capture,
Raw, RemoteHost, ReqBody, Vault) Raw, RemoteHost, ReqBody, Vault)
import Servant.API.ContentTypes (AcceptHeader (..), import Servant.API.ContentTypes (AcceptHeader (..),
AllCTRender (..), AllCTRender (..),
AllCTUnrender (..)) AllCTUnrender (..),
import Servant.API.ResponseHeaders (Headers, getResponse, GetHeaders, AllMime,
getHeaders) canHandleAcceptH)
import Servant.API.ResponseHeaders (GetHeaders, Headers, getHeaders,
getResponse)
import Servant.Server.Internal.Router import Servant.Server.Internal.Router
import Servant.Server.Internal.RoutingApplication import Servant.Server.Internal.RoutingApplication
@ -60,7 +62,7 @@ import Web.HttpApiData.Internal (parseUrlPieceMaybe, parseHeaderMaybe,
class HasServer layout where class HasServer layout where
type ServerT layout (m :: * -> *) :: * 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) 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 type ServerT (a :<|> b) m = ServerT a m :<|> ServerT b m
route Proxy server = choice (route pa (extractL <$> server)) route Proxy server = choice (route pa ((\ (a :<|> _) -> a) <$> server))
(route pb (extractR <$> server)) (route pb ((\ (_ :<|> b) -> b) <$> server))
where pa = Proxy :: Proxy a where pa = Proxy :: Proxy a
pb = Proxy :: Proxy b pb = Proxy :: Proxy b
@ -112,13 +114,15 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout)
type ServerT (Capture capture a :> sublayout) m = type ServerT (Capture capture a :> sublayout) m =
a -> ServerT sublayout m a -> ServerT sublayout m
route Proxy subserver = route Proxy d =
DynamicRouter $ \ first -> DynamicRouter $ \ first ->
route (Proxy :: Proxy sublayout) route (Proxy :: Proxy sublayout)
(case captured captureProxy first of (addCapture d $ case captured captureProxy first of
Nothing -> return $ failWith NotFound Nothing -> return $ Fail err404
Just v -> feedTo subserver v) Just v -> return $ Route v
where captureProxy = Proxy :: Proxy (Capture capture a) )
where
captureProxy = Proxy :: Proxy (Capture capture a)
allowedMethodHead :: Method -> Request -> Bool allowedMethodHead :: Method -> Request -> Bool
allowedMethodHead method request = method == methodGet && requestMethod request == methodHead allowedMethodHead method request = method == methodGet && requestMethod request == methodHead
@ -131,57 +135,65 @@ processMethodRouter :: forall a. ConvertibleStrings a B.ByteString
-> Maybe [(HeaderName, B.ByteString)] -> Maybe [(HeaderName, B.ByteString)]
-> Request -> RouteResult Response -> Request -> RouteResult Response
processMethodRouter handleA status method headers request = case handleA of processMethodRouter handleA status method headers request = case handleA of
Nothing -> failWith UnsupportedMediaType Nothing -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does
Just (contentT, body) -> succeedWith $ responseLBS status hdrs bdy Just (contentT, body) -> Route $ responseLBS status hdrs bdy
where where
bdy = if allowedMethodHead method request then "" else body bdy = if allowedMethodHead method request then "" else body
hdrs = (hContentType, cs contentT) : (fromMaybe [] headers) 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) methodRouter :: (AllCTRender ctypes a)
=> Method -> Proxy ctypes -> Status => Method -> Proxy ctypes -> Status
-> IO (RouteResult (ExceptT ServantErr IO a)) -> Delayed (ExceptT ServantErr IO a)
-> Router -> Router
methodRouter method proxy status action = LeafRouter route' methodRouter method proxy status action = LeafRouter route'
where where
route' request respond route' request respond
| pathIsEmpty request && allowedMethod method request = do | pathIsEmpty request =
runAction action respond $ \ output -> do let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request in runAction (action `addMethodCheck` methodCheck method request
handleA = handleAcceptH proxy (AcceptHeader accH) output `addAcceptCheck` acceptCheck proxy accH
processMethodRouter handleA status method Nothing request ) respond $ \ output -> do
| pathIsEmpty request && requestMethod request /= method = let handleA = handleAcceptH proxy (AcceptHeader accH) output
respond $ failWith WrongMethod processMethodRouter handleA status method Nothing request
| otherwise = respond $ failWith NotFound | otherwise = respond $ Fail err404
methodRouterHeaders :: (GetHeaders (Headers h v), AllCTRender ctypes v) methodRouterHeaders :: (GetHeaders (Headers h v), AllCTRender ctypes v)
=> Method -> Proxy ctypes -> Status => Method -> Proxy ctypes -> Status
-> IO (RouteResult (ExceptT ServantErr IO (Headers h v))) -> Delayed (ExceptT ServantErr IO (Headers h v))
-> Router -> Router
methodRouterHeaders method proxy status action = LeafRouter route' methodRouterHeaders method proxy status action = LeafRouter route'
where where
route' request respond route' request respond
| pathIsEmpty request && allowedMethod method request = do | pathIsEmpty request =
runAction action respond $ \ output -> do let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request in runAction (action `addMethodCheck` methodCheck method request
headers = getHeaders output `addAcceptCheck` acceptCheck proxy accH
handleA = handleAcceptH proxy (AcceptHeader accH) (getResponse output) ) respond $ \ output -> do
processMethodRouter handleA status method (Just headers) request let headers = getHeaders output
| pathIsEmpty request && requestMethod request /= method = handleA = handleAcceptH proxy (AcceptHeader accH) (getResponse output)
respond $ failWith WrongMethod processMethodRouter handleA status method (Just headers) request
| otherwise = respond $ failWith NotFound | otherwise = respond $ Fail err404
methodRouterEmpty :: Method methodRouterEmpty :: Method
-> IO (RouteResult (ExceptT ServantErr IO ())) -> Delayed (ExceptT ServantErr IO ())
-> Router -> Router
methodRouterEmpty method action = LeafRouter route' methodRouterEmpty method action = LeafRouter route'
where where
route' request respond route' request respond
| pathIsEmpty request && allowedMethod method request = do | pathIsEmpty request = do
runAction action respond $ \ () -> runAction (addMethodCheck action (methodCheck method request)) respond $ \ () ->
succeedWith $ responseLBS noContent204 [] "" Route $! responseLBS noContent204 [] ""
| pathIsEmpty request && requestMethod request /= method = | otherwise = respond $ Fail err404
respond $ failWith WrongMethod
| otherwise = respond $ failWith NotFound
-- | If you have a 'Delete' endpoint in your API, -- | If you have a 'Delete' endpoint in your API,
-- the handler for this endpoint is meant to delete -- the handler for this endpoint is meant to delete
@ -301,7 +313,7 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout)
route Proxy subserver = WithRequest $ \ request -> route Proxy subserver = WithRequest $ \ request ->
let mheader = parseHeaderMaybe =<< lookup str (requestHeaders 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) where str = fromString $ symbolVal (Proxy :: Proxy sym)
-- | When implementing the handler for a 'Post' endpoint, -- | 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 Nothing -> Nothing -- param present with no value -> Nothing
Just (Just v) -> parseQueryParamMaybe v -- if present, we try to convert to Just (Just v) -> parseQueryParamMaybe v -- if present, we try to convert to
-- the right type -- 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) where paramname = cs $ symbolVal (Proxy :: Proxy sym)
-- | If you use @'QueryParams' "authors" Text@ in one of the endpoints for your API, -- | 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 -- corresponding values
parameters = filter looksLikeParam querytext parameters = filter looksLikeParam querytext
values = mapMaybe (convert . snd) parameters 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) where paramname = cs $ symbolVal (Proxy :: Proxy sym)
looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]") looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]")
convert Nothing = Nothing convert Nothing = Nothing
@ -538,7 +550,7 @@ instance (KnownSymbol sym, HasServer sublayout)
Just Nothing -> True -- param is there, with no value Just Nothing -> True -- param is there, with no value
Just (Just v) -> examine v -- param with a value Just (Just v) -> examine v -- param with a value
Nothing -> False -- param not in the query string 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) where paramname = cs $ symbolVal (Proxy :: Proxy sym)
examine v | v == "true" || v == "1" || v == "" = True examine v | v == "true" || v == "1" || v == "" = True
| otherwise = False | otherwise = False
@ -556,10 +568,11 @@ instance HasServer Raw where
type ServerT Raw m = Application type ServerT Raw m = Application
route Proxy rawApplication = LeafRouter $ \ request respond -> do route Proxy rawApplication = LeafRouter $ \ request respond -> do
r <- rawApplication r <- runDelayed rawApplication
case r of case r of
RR (Left err) -> respond $ failWith err Route app -> app request (respond . Route)
RR (Right app) -> app request (respond . succeedWith) Fail a -> respond $ Fail a
FailFatal e -> respond $ FailFatal e
-- | If you use 'ReqBody' in one of the endpoints for your API, -- | If you use 'ReqBody' in one of the endpoints for your API,
-- this automatically requires your server-side handler to be a function -- this automatically requires your server-side handler to be a function
@ -589,19 +602,21 @@ instance ( AllCTUnrender list a, HasServer sublayout
a -> ServerT sublayout m a -> ServerT sublayout m
route Proxy subserver = WithRequest $ \ request -> route Proxy subserver = WithRequest $ \ request ->
route (Proxy :: Proxy sublayout) $ do route (Proxy :: Proxy sublayout) (addBodyCheck subserver (bodyCheck request))
-- See HTTP RFC 2616, section 7.2.1 where
-- http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1 bodyCheck request = do
-- See also "W3C Internet Media Type registration, consistency of use" -- See HTTP RFC 2616, section 7.2.1
-- http://www.w3.org/2001/tag/2002/0129-mime -- http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1
let contentTypeH = fromMaybe "application/octet-stream" -- See also "W3C Internet Media Type registration, consistency of use"
$ lookup hContentType $ requestHeaders request -- http://www.w3.org/2001/tag/2002/0129-mime
mrqbody <- handleCTypeH (Proxy :: Proxy list) (cs contentTypeH) let contentTypeH = fromMaybe "application/octet-stream"
<$> lazyRequestBody request $ lookup hContentType $ requestHeaders request
case mrqbody of mrqbody <- handleCTypeH (Proxy :: Proxy list) (cs contentTypeH)
Nothing -> return $ failWith $ UnsupportedMediaType <$> lazyRequestBody request
Just (Left e) -> return $ failWith $ InvalidBody e case mrqbody of
Just (Right v) -> feedTo subserver v 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 -- | Make sure the incoming request starts with @"/path"@, strip it and
-- pass the rest of the request path to @sublayout@. -- 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 type ServerT (RemoteHost :> api) m = SockAddr -> ServerT api m
route Proxy subserver = WithRequest $ \req -> 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 instance HasServer api => HasServer (IsSecure :> api) where
type ServerT (IsSecure :> api) m = IsSecure -> ServerT api m type ServerT (IsSecure :> api) m = IsSecure -> ServerT api m
route Proxy subserver = WithRequest $ \req -> 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 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 type ServerT (Vault :> api) m = Vault -> ServerT api m
route Proxy subserver = WithRequest $ \req -> 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 instance HasServer api => HasServer (HttpVersion :> api) where
type ServerT (HttpVersion :> api) m = HttpVersion -> ServerT api m type ServerT (HttpVersion :> api) m = HttpVersion -> ServerT api m
route Proxy subserver = WithRequest $ \req -> 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 :: Request -> Bool
pathIsEmpty = go . pathInfo pathIsEmpty = go . pathInfo

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

@ -1,13 +1,13 @@
{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE CPP #-}
module Servant.Server.Internal.Router where module Servant.Server.Internal.Router where
import Data.Map (Map) import Data.Map (Map)
import qualified Data.Map as M import qualified Data.Map as M
import Data.Monoid ((<>))
import Data.Text (Text) import Data.Text (Text)
import Network.Wai (Request, Response, pathInfo) import Network.Wai (Request, Response, pathInfo)
import Servant.Server.Internal.RoutingApplication import Servant.Server.Internal.RoutingApplication
import Servant.Server.Internal.ServantErr
type Router = Router' RoutingApplication type Router = Router' RoutingApplication
@ -63,17 +63,31 @@ runRouter (StaticRouter table) request respond =
| Just router <- M.lookup first table | Just router <- M.lookup first table
-> let request' = request { pathInfo = rest } -> let request' = request { pathInfo = rest }
in runRouter router request' respond in runRouter router request' respond
_ -> respond $ failWith NotFound _ -> respond $ Fail err404
runRouter (DynamicRouter fun) request respond = runRouter (DynamicRouter fun) request respond =
case pathInfo request of case pathInfo request of
first : rest first : rest
-> let request' = request { pathInfo = rest } -> let request' = request { pathInfo = rest }
in runRouter (fun first) request' respond in runRouter (fun first) request' respond
_ -> respond $ failWith NotFound _ -> respond $ Fail err404
runRouter (LeafRouter app) request respond = app request respond runRouter (LeafRouter app) request respond = app request respond
runRouter (Choice r1 r2) request respond = runRouter (Choice r1 r2) request respond =
runRouter r1 request $ \ mResponse1 -> runRouter r1 request $ \ mResponse1 -> case mResponse1 of
if isMismatch mResponse1 Fail _ -> runRouter r2 request $ \ mResponse2 ->
then runRouter r2 request $ \ mResponse2 -> respond (highestPri mResponse1 mResponse2)
respond (mResponse1 <> mResponse2) _ -> respond mResponse1
else 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 = (<)

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

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

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

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

224
servant-server/test/Servant/Server/ErrorSpec.hs Normal file
View 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
-- }}}

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

@ -1,6 +1,7 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
@ -17,7 +18,6 @@ import Control.Monad.Trans.Except (ExceptT, throwE)
import Data.Aeson (FromJSON, ToJSON, decode', encode) import Data.Aeson (FromJSON, ToJSON, decode', encode)
import Data.ByteString.Conversion () import Data.ByteString.Conversion ()
import Data.Char (toUpper) import Data.Char (toUpper)
import Data.Monoid ((<>))
import Data.Proxy (Proxy (Proxy)) import Data.Proxy (Proxy (Proxy))
import Data.String (fromString) import Data.String (fromString)
import Data.String.Conversions (cs) import Data.String.Conversions (cs)
@ -26,18 +26,13 @@ import GHC.Generics (Generic)
import Network.HTTP.Types (hAccept, hContentType, import Network.HTTP.Types (hAccept, hContentType,
methodDelete, methodGet, methodHead, methodDelete, methodGet, methodHead,
methodPatch, methodPost, methodPut, methodPatch, methodPost, methodPut,
ok200, parseQuery, status409, ok200, parseQuery, Status(..))
Status(..))
import Network.Wai (Application, Request, pathInfo, import Network.Wai (Application, Request, pathInfo,
queryString, rawQueryString, queryString, rawQueryString,
responseLBS, responseBuilder) responseLBS, responseBuilder)
import Network.Wai.Internal (Response(ResponseBuilder)) import Network.Wai.Internal (Response(ResponseBuilder))
import Network.Wai.Test (defaultRequest, request, import Network.Wai.Test (defaultRequest, request,
runSession, simpleBody) 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, import Servant.API ((:<|>) (..), (:>), Capture, Delete,
Get, Header (..), Headers, Get, Header (..), Headers,
HttpVersion, IsSecure (..), JSON, HttpVersion, IsSecure (..), JSON,
@ -46,12 +41,14 @@ import Servant.API ((:<|>) (..), (:>), Capture, Delete,
Raw, RemoteHost, ReqBody, Raw, RemoteHost, ReqBody,
addHeader) addHeader)
import Servant.Server (Server, serve, ServantErr(..), err404) 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 import Servant.Server.Internal.Router
(tweakResponse, runRouter, (tweakResponse, runRouter,
Router, Router'(LeafRouter)) Router, Router'(LeafRouter))
import Servant.Server.Internal.RoutingApplication
(RouteResult(..), RouteMismatch(..),
toApplication)
-- * test data types -- * test data types
@ -98,8 +95,6 @@ spec = do
headerSpec headerSpec
rawSpec rawSpec
unionSpec unionSpec
prioErrorsSpec
errorsSpec
routerSpec routerSpec
responseHeadersSpec responseHeadersSpec
miscReqCombinatorsSpec miscReqCombinatorsSpec
@ -158,9 +153,9 @@ getSpec = do
it "returns 204 if the type is '()'" $ do it "returns 204 if the type is '()'" $ do
get "/empty" `shouldRespondWith` ""{ matchStatus = 204 } get "/empty" `shouldRespondWith` ""{ matchStatus = 204 }
it "returns 415 if the Accept header is not supported" $ do it "returns 406 if the Accept header is not supported" $ do
Test.Hspec.Wai.request methodGet "" [(hAccept, "crazy/mime")] "" Test.Hspec.Wai.request methodGet "" [(hAccept, "crazy/mime")] ""
`shouldRespondWith` 415 `shouldRespondWith` 406
headSpec :: Spec headSpec :: Spec
@ -186,9 +181,9 @@ headSpec = do
response <- Test.Hspec.Wai.request methodHead "/empty" [] "" response <- Test.Hspec.Wai.request methodHead "/empty" [] ""
return response `shouldRespondWith` ""{ matchStatus = 204 } return response `shouldRespondWith` ""{ matchStatus = 204 }
it "returns 415 if the Accept header is not supported" $ do it "returns 406 if the Accept header is not supported" $ do
Test.Hspec.Wai.request methodHead "" [(hAccept, "crazy/mime")] "" Test.Hspec.Wai.request methodHead "" [(hAccept, "crazy/mime")] ""
`shouldRespondWith` 415 `shouldRespondWith` 406
type QueryParamApi = QueryParam "name" String :> Get '[JSON] Person type QueryParamApi = QueryParam "name" String :> Get '[JSON] Person
@ -264,13 +259,13 @@ queryParamSpec = do
} }
let params3'' = "?unknown=" let params3'' = "?unknown="
response3' <- Network.Wai.Test.request defaultRequest{ response3'' <- Network.Wai.Test.request defaultRequest{
rawQueryString = params3'', rawQueryString = params3'',
queryString = parseQuery params3'', queryString = parseQuery params3'',
pathInfo = ["b"] pathInfo = ["b"]
} }
liftIO $ liftIO $
decode' (simpleBody response3') `shouldBe` Just alice{ decode' (simpleBody response3'') `shouldBe` Just alice{
name = "Alice" name = "Alice"
} }
@ -311,7 +306,7 @@ postSpec = do
it "returns 204 if the type is '()'" $ do it "returns 204 if the type is '()'" $ do
post' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 } post' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 }
it "responds with 415 if the requested media type is unsupported" $ do it "responds with 415 if the request body media type is unsupported" $ do
let post'' x = Test.Hspec.Wai.request methodPost x [(hContentType let post'' x = Test.Hspec.Wai.request methodPost x [(hContentType
, "application/nonsense")] , "application/nonsense")]
post'' "/" "anything at all" `shouldRespondWith` 415 post'' "/" "anything at all" `shouldRespondWith` 415
@ -353,7 +348,7 @@ putSpec = do
it "returns 204 if the type is '()'" $ do it "returns 204 if the type is '()'" $ do
put' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 } put' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 }
it "responds with 415 if the requested media type is unsupported" $ do it "responds with 415 if the request body media type is unsupported" $ do
let put'' x = Test.Hspec.Wai.request methodPut x [(hContentType let put'' x = Test.Hspec.Wai.request methodPut x [(hContentType
, "application/nonsense")] , "application/nonsense")]
put'' "/" "anything at all" `shouldRespondWith` 415 put'' "/" "anything at all" `shouldRespondWith` 415
@ -395,7 +390,7 @@ patchSpec = do
it "returns 204 if the type is '()'" $ do it "returns 204 if the type is '()'" $ do
patch' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 } patch' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 }
it "responds with 415 if the requested media type is unsupported" $ do it "responds with 415 if the request body media type is unsupported" $ do
let patch'' x = Test.Hspec.Wai.request methodPatch x [(hContentType let patch'' x = Test.Hspec.Wai.request methodPatch x [(hContentType
, "application/nonsense")] , "application/nonsense")]
patch'' "/" "anything at all" `shouldRespondWith` 415 patch'' "/" "anything at all" `shouldRespondWith` 415
@ -524,104 +519,11 @@ responseHeadersSpec = describe "ResponseHeaders" $ do
Test.Hspec.Wai.request method "blahblah" [] "" Test.Hspec.Wai.request method "blahblah" [] ""
`shouldRespondWith` 404 `shouldRespondWith` 404
it "returns 415 if the Accept header is not supported" $ it "returns 406 if the Accept header is not supported" $
forM_ methods $ \(method,_) -> forM_ methods $ \(method,_) ->
Test.Hspec.Wai.request method "" [(hAccept, "crazy/mime")] "" Test.Hspec.Wai.request method "" [(hAccept, "crazy/mime")] ""
`shouldRespondWith` 415 `shouldRespondWith` 406
type PrioErrorsApi = ReqBody '[JSON] Person :> "foo" :> Get '[JSON] Integer
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 :: Spec
routerSpec = do routerSpec = do
@ -631,7 +533,7 @@ routerSpec = do
router', router :: Router router', router :: Router
router' = tweakResponse (twk <$>) 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 :: Response -> Response
twk (ResponseBuilder (Status i s) hs b) = ResponseBuilder (Status (i + 1) s) hs b twk (ResponseBuilder (Status i s) hs b) = ResponseBuilder (Status (i + 1) s) hs b

1
servant/CHANGELOG.md
View file

@ -6,6 +6,7 @@ HEAD
* Add more instances for (:<|>) * Add more instances for (:<|>)
* Use `http-api-data` instead of `Servant.Common.Text` * Use `http-api-data` instead of `Servant.Common.Text`
* Remove matrix params. * Remove matrix params.
* Add PlainText String MimeRender and MimeUnrender instances.
0.4.2 0.4.2
----- -----

34
servant/src/Servant/API/ContentTypes.hs
View file

@ -57,12 +57,14 @@ module Servant.API.ContentTypes
, AcceptHeader(..) , AcceptHeader(..)
, AllCTRender(..) , AllCTRender(..)
, AllCTUnrender(..) , AllCTUnrender(..)
, AllMime(..)
, AllMimeRender(..) , AllMimeRender(..)
, AllMimeUnrender(..) , AllMimeUnrender(..)
, FromFormUrlEncoded(..) , FromFormUrlEncoded(..)
, ToFormUrlEncoded(..) , ToFormUrlEncoded(..)
, IsNonEmpty , IsNonEmpty
, eitherDecodeLenient , eitherDecodeLenient
, canHandleAcceptH
) where ) where
#if !MIN_VERSION_base(4,8,0) #if !MIN_VERSION_base(4,8,0)
@ -80,6 +82,8 @@ import qualified Data.ByteString as BS
import Data.ByteString.Lazy (ByteString, fromStrict, import Data.ByteString.Lazy (ByteString, fromStrict,
toStrict) toStrict)
import qualified Data.ByteString.Lazy as B import qualified Data.ByteString.Lazy as B
import qualified Data.ByteString.Lazy.Char8 as BC
import Data.Maybe (isJust)
import Data.Monoid import Data.Monoid
import Data.String.Conversions (cs) import Data.String.Conversions (cs)
import qualified Data.Text as TextS import qualified Data.Text as TextS
@ -155,14 +159,13 @@ newtype AcceptHeader = AcceptHeader BS.ByteString
class Accept ctype => MimeRender ctype a where class Accept ctype => MimeRender ctype a where
mimeRender :: Proxy ctype -> a -> ByteString 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 -- If the Accept header can be matched, returns (Just) a tuple of the
-- Content-Type and response (serialization of @a@ into the appropriate -- Content-Type and response (serialization of @a@ into the appropriate
-- mimetype). -- mimetype).
handleAcceptH :: Proxy list -> AcceptHeader -> a -> Maybe (ByteString, ByteString) handleAcceptH :: Proxy list -> AcceptHeader -> a -> Maybe (ByteString, ByteString)
instance ( AllMimeRender ctyps a, IsNonEmpty ctyps instance (AllMimeRender ctyps a, IsNonEmpty ctyps) => AllCTRender ctyps a where
) => AllCTRender ctyps a where
handleAcceptH _ (AcceptHeader accept) val = M.mapAcceptMedia lkup accept handleAcceptH _ (AcceptHeader accept) val = M.mapAcceptMedia lkup accept
where pctyps = Proxy :: Proxy ctyps where pctyps = Proxy :: Proxy ctyps
amrs = allMimeRender pctyps val amrs = allMimeRender pctyps val
@ -210,11 +213,24 @@ instance ( AllMimeUnrender ctyps a, IsNonEmpty ctyps
-------------------------------------------------------------------------- --------------------------------------------------------------------------
-- * Utils (Internal) -- * 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 -- 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 allMimeRender :: Proxy list
-> a -- value to serialize -> a -- value to serialize
-> [(M.MediaType, ByteString)] -- content-types/response pairs -> [(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 -- 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 allMimeUnrender :: Proxy list
-> ByteString -> ByteString
-> [(M.MediaType, Either String a)] -> [(M.MediaType, Either String a)]
@ -279,6 +295,10 @@ instance MimeRender PlainText TextL.Text where
instance MimeRender PlainText TextS.Text where instance MimeRender PlainText TextS.Text where
mimeRender _ = fromStrict . TextS.encodeUtf8 mimeRender _ = fromStrict . TextS.encodeUtf8
-- | @BC.pack@
instance MimeRender PlainText String where
mimeRender _ = BC.pack
-- | @id@ -- | @id@
instance MimeRender OctetStream ByteString where instance MimeRender OctetStream ByteString where
mimeRender _ = id mimeRender _ = id
@ -328,6 +348,10 @@ instance MimeUnrender PlainText TextL.Text where
instance MimeUnrender PlainText TextS.Text where instance MimeUnrender PlainText TextS.Text where
mimeUnrender _ = left show . TextS.decodeUtf8' . toStrict mimeUnrender _ = left show . TextS.decodeUtf8' . toStrict
-- | @Right . BC.unpack@
instance MimeUnrender PlainText String where
mimeUnrender _ = Right . BC.unpack
-- | @Right . id@ -- | @Right . id@
instance MimeUnrender OctetStream ByteString where instance MimeUnrender OctetStream ByteString where
mimeUnrender _ = Right . id mimeUnrender _ = Right . id

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

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