6a4c967 · typeable/servant

git.iko.soy/typeable/servant

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

Fix error priority and retries

commit6a4c96759053a69d75514bf356291575c9cd5ad0 authorJulian Arni <jkarni@gmail.com> dateMon 26 Oct 2015, 17:17 (11 years ago) parentc970b2b 9c12b78

14 files changed+637−344

compare with master

unifiedsplit

servant-docs/src/Servant/Docs/Internal.hs+19−34 servant-examples/auth-combinator/auth-combinator.hs+11−10 servant-server/CHANGELOG.md+3 servant-server/servant-server.cabal+2 servant-server/src/Servant/Server.hs+4−1 servant-server/src/Servant/Server/Internal.hs+91−76 servant-server/src/Servant/Server/Internal/Router.hs+23−9 servant-server/src/Servant/Server/Internal/RoutingApplication.hs+194−90 servant-server/src/Servant/Server/Internal/ServantErr.hs+1−1 servant-server/test/Servant/Server/ErrorSpec.hs+224 servant-server/test/Servant/ServerSpec.hs+20−118 servant/CHANGELOG.md+1 servant/src/Servant/API/ContentTypes.hs+29−5 servant/test/Servant/API/ContentTypesSpec.hs+15

servant-docs/src/Servant/Docs/Internal.hs+19−34

@@ -496,19 +496,6 @@ sampleByteStrings ctypes@Proxy Proxy =

496496 enc (t, s) = uncurry (t,,) <$> allMimeRender ctypes s

497497 in concatMap enc samples'

498498

499−-- | Generate a list of 'MediaType' values describing the content types

500−-- accepted by an API component.

501−class SupportedTypes (list :: [*]) where

502− supportedTypes :: Proxy list -> [M.MediaType]

503−

504−instance SupportedTypes '[] where

505− supportedTypes Proxy = []

506−

507−instance (Accept ctype, SupportedTypes rest) => SupportedTypes (ctype ': rest)

508− where

509− supportedTypes Proxy =

510− contentType (Proxy :: Proxy ctype) : supportedTypes (Proxy :: Proxy rest)

511−

512499-- | The class that helps us automatically get documentation

513500-- for GET parameters.

514501--

@@ -709,14 +696,14 @@ instance

709696#if MIN_VERSION_base(4,8,0)

710697 {-# OVERLAPPABLe #-}

711698#endif

712− (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)

699+ (ToSample a, IsNonEmpty cts, AllMimeRender cts a)

713700 => HasDocs (Delete cts a) where

714701 docsFor Proxy (endpoint, action) DocOptions{..} =

715702 single endpoint' action'

716703

717704 where endpoint' = endpoint & method .~ DocDELETE

718705 action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)

719− & response.respTypes .~ supportedTypes t

706+ & response.respTypes .~ allMime t

720707 t = Proxy :: Proxy cts

721708 p = Proxy :: Proxy a

722709

@@ -724,7 +711,7 @@ instance

724711#if MIN_VERSION_base(4,8,0)

725712 {-# OVERLAPPING #-}

726713#endif

727− (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts

714+ (ToSample a, IsNonEmpty cts, AllMimeRender cts a

728715 , AllHeaderSamples ls , GetHeaders (HList ls) )

729716 => HasDocs (Delete cts (Headers ls a)) where

730717 docsFor Proxy (endpoint, action) DocOptions{..} =

@@ -733,7 +720,7 @@ instance

733720 where hdrs = allHeaderToSample (Proxy :: Proxy ls)

734721 endpoint' = endpoint & method .~ DocDELETE

735722 action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)

736− & response.respTypes .~ supportedTypes t

723+ & response.respTypes .~ allMime t

737724 & response.respHeaders .~ hdrs

738725 t = Proxy :: Proxy cts

739726 p = Proxy :: Proxy a

@@ -742,14 +729,14 @@ instance

742729#if MIN_VERSION_base(4,8,0)

743730 {-# OVERLAPPABLe #-}

744731#endif

745− (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)

732+ (ToSample a, IsNonEmpty cts, AllMimeRender cts a)

746733 => HasDocs (Get cts a) where

747734 docsFor Proxy (endpoint, action) DocOptions{..} =

748735 single endpoint' action'

749736

750737 where endpoint' = endpoint & method .~ DocGET

751738 action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)

752− & response.respTypes .~ supportedTypes t

739+ & response.respTypes .~ allMime t

753740 t = Proxy :: Proxy cts

754741 p = Proxy :: Proxy a

755742

@@ -757,7 +744,7 @@ instance

757744#if MIN_VERSION_base(4,8,0)

758745 {-# OVERLAPPING #-}

759746#endif

760− (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts

747+ (ToSample a, IsNonEmpty cts, AllMimeRender cts a

761748 , AllHeaderSamples ls , GetHeaders (HList ls) )

762749 => HasDocs (Get cts (Headers ls a)) where

763750 docsFor Proxy (endpoint, action) DocOptions{..} =

@@ -766,7 +753,7 @@ instance

766753 where hdrs = allHeaderToSample (Proxy :: Proxy ls)

767754 endpoint' = endpoint & method .~ DocGET

768755 action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)

769− & response.respTypes .~ supportedTypes t

756+ & response.respTypes .~ allMime t

770757 & response.respHeaders .~ hdrs

771758 t = Proxy :: Proxy cts

772759 p = Proxy :: Proxy a

@@ -784,14 +771,14 @@ instance

784771#if MIN_VERSION_base(4,8,0)

785772 {-# OVERLAPPABLE #-}

786773#endif

787− (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)

774+ (ToSample a, IsNonEmpty cts, AllMimeRender cts a)

788775 => HasDocs (Post cts a) where

789776 docsFor Proxy (endpoint, action) DocOptions{..} =

790777 single endpoint' action'

791778

792779 where endpoint' = endpoint & method .~ DocPOST

793780 action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)

794− & response.respTypes .~ supportedTypes t

781+ & response.respTypes .~ allMime t

795782 & response.respStatus .~ 201

796783 t = Proxy :: Proxy cts

797784 p = Proxy :: Proxy a

@@ -800,7 +787,7 @@ instance

800787#if MIN_VERSION_base(4,8,0)

801788 {-# OVERLAPPING #-}

802789#endif

803− (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts

790+ (ToSample a, IsNonEmpty cts, AllMimeRender cts a

804791 , AllHeaderSamples ls , GetHeaders (HList ls) )

805792 => HasDocs (Post cts (Headers ls a)) where

806793 docsFor Proxy (endpoint, action) DocOptions{..} =

@@ -809,7 +796,7 @@ instance

809796 where hdrs = allHeaderToSample (Proxy :: Proxy ls)

810797 endpoint' = endpoint & method .~ DocPOST

811798 action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)

812− & response.respTypes .~ supportedTypes t

799+ & response.respTypes .~ allMime t

813800 & response.respStatus .~ 201

814801 & response.respHeaders .~ hdrs

815802 t = Proxy :: Proxy cts

@@ -819,14 +806,14 @@ instance

819806#if MIN_VERSION_base(4,8,0)

820807 {-# OVERLAPPABLE #-}

821808#endif

822− (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts)

809+ (ToSample a, IsNonEmpty cts, AllMimeRender cts a)

823810 => HasDocs (Put cts a) where

824811 docsFor Proxy (endpoint, action) DocOptions{..} =

825812 single endpoint' action'

826813

827814 where endpoint' = endpoint & method .~ DocPUT

828815 action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)

829− & response.respTypes .~ supportedTypes t

816+ & response.respTypes .~ allMime t

830817 & response.respStatus .~ 200

831818 t = Proxy :: Proxy cts

832819 p = Proxy :: Proxy a

@@ -835,8 +822,8 @@ instance

835822#if MIN_VERSION_base(4,8,0)

836823 {-# OVERLAPPING #-}

837824#endif

838− (ToSample a, IsNonEmpty cts, AllMimeRender cts a, SupportedTypes cts

839− , AllHeaderSamples ls , GetHeaders (HList ls) )

825+ ( ToSample a, IsNonEmpty cts, AllMimeRender cts a,

826+ AllHeaderSamples ls , GetHeaders (HList ls) )

840827 => HasDocs (Put cts (Headers ls a)) where

841828 docsFor Proxy (endpoint, action) DocOptions{..} =

842829 single endpoint' action'

@@ -844,7 +831,7 @@ instance

844831 where hdrs = allHeaderToSample (Proxy :: Proxy ls)

845832 endpoint' = endpoint & method .~ DocPUT

846833 action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p)

847− & response.respTypes .~ supportedTypes t

834+ & response.respTypes .~ allMime t

848835 & response.respStatus .~ 200

849836 & response.respHeaders .~ hdrs

850837 t = Proxy :: Proxy cts

@@ -890,8 +877,7 @@ instance HasDocs Raw where

890877-- example data. However, there's no reason to believe that the instances of

891878-- 'AllMimeUnrender' and 'AllMimeRender' actually agree (or to suppose that

892879-- both are even defined) for any particular type.

893−instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, HasDocs sublayout

894− , SupportedTypes cts)

880+instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, HasDocs sublayout)

895881 => HasDocs (ReqBody cts a :> sublayout) where

896882

897883 docsFor Proxy (endpoint, action) =

@@ -899,7 +885,7 @@ instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, HasDocs sublayout

899885

900886 where sublayoutP = Proxy :: Proxy sublayout

901887 action' = action & rqbody .~ sampleByteString t p

902− & rqtypes .~ supportedTypes t

888+ & rqtypes .~ allMime t

903889 t = Proxy :: Proxy cts

904890 p = Proxy :: Proxy a

905891

@@ -957,4 +943,3 @@ instance ToSample a => ToSample (Product a)

957943instance ToSample a => ToSample (First a)

958944instance ToSample a => ToSample (Last a)

959945instance ToSample a => ToSample (Dual a)

960−

servant-examples/auth-combinator/auth-combinator.hs+11−10

@@ -5,11 +5,11 @@

55{-# LANGUAGE ScopedTypeVariables #-}

66{-# LANGUAGE TypeFamilies #-}

77{-# LANGUAGE TypeOperators #-}

89import Data.Aeson

910import Data.ByteString (ByteString)

1011import Data.Text (Text)

1112import GHC.Generics

12−import Network.HTTP.Types

1313import Network.Wai

1414import Network.Wai.Handler.Warp

1515import Servant

@@ -28,15 +28,16 @@ data AuthProtected

2828instance HasServer rest => HasServer (AuthProtected :> rest) where

2929 type ServerT (AuthProtected :> rest) m = ServerT rest m

3030

31− route Proxy a = WithRequest $ \ request ->

32− route (Proxy :: Proxy rest) $ do

33− case lookup "Cookie" (requestHeaders request) of

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

35− Just v -> do

36− authGranted <- isGoodCookie v

37− if authGranted

38− then a

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

31+ route Proxy subserver = WithRequest $ \ request ->

32+ route (Proxy :: Proxy rest) $ addAcceptCheck subserver $ cookieCheck request

33+ where

34+ cookieCheck req = case lookup "Cookie" (requestHeaders req) of

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

36+ Just v -> do

37+ authGranted <- isGoodCookie v

38+ if authGranted

39+ then return $ Route ()

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

4041

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

4243

servant-server/CHANGELOG.md+3

@@ -5,6 +5,9 @@ HEAD

55* Drop `EitherT` in favor of `ExceptT`

66* Use `http-api-data` instead of `Servant.Common.Text`

77* Remove matrix params.

8+* Remove `RouteMismatch`.

9+* Redefined constructors of `RouteResult`.

10+* Added `Delayed` and related functions (`addMethodCheck`, `addAcceptCheck`, `addBodyCheck`, `runDelayed`)

811

9120.4.1

1013-----

servant-server/servant-server.cabal+2

@@ -95,6 +95,7 @@ test-suite spec

9595 Servant.Server.Internal.EnterSpec

9696 Servant.ServerSpec

9797 Servant.Utils.StaticFilesSpec

98+ Servant.Server.ErrorSpec

9899 build-depends:

99100 base == 4.*

100101 , aeson

@@ -108,6 +109,7 @@ test-suite spec

108109 , network >= 2.6

109110 , QuickCheck

110111 , parsec

112+ , safe

111113 , servant

112114 , servant-server

113115 , string-conversions

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

@@ -103,7 +103,10 @@ import Servant.Server.Internal.Enter

103103-- > main = Network.Wai.Handler.Warp.run 8080 app

104104--

105105serve :: HasServer layout => Proxy layout -> Server layout -> Application

106−serve p server = toApplication (runRouter (route p (return (RR (Right server)))))

106+serve p server = toApplication (runRouter (route p d))

107+ where

108+ d = Delayed r r r (\ _ _ -> Route server)

109+ r = return (Route ())

107110

108111

109112-- Documentation

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

@@ -1,15 +1,15 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE FlexibleContexts #-}

4−{-# LANGUAGE FlexibleInstances #-}

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE FlexibleContexts #-}

4+{-# LANGUAGE FlexibleInstances #-}

55{-# LANGUAGE GeneralizedNewtypeDeriving #-}

6−{-# LANGUAGE OverloadedStrings #-}

7−{-# LANGUAGE PolyKinds #-}

8−{-# LANGUAGE ScopedTypeVariables #-}

9−{-# LANGUAGE TypeFamilies #-}

10−{-# LANGUAGE TypeOperators #-}

6+{-# LANGUAGE OverloadedStrings #-}

7+{-# LANGUAGE PolyKinds #-}

8+{-# LANGUAGE ScopedTypeVariables #-}

9+{-# LANGUAGE TypeFamilies #-}

10+{-# LANGUAGE TypeOperators #-}

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

12−{-# LANGUAGE OverlappingInstances #-}

12+{-# LANGUAGE OverlappingInstances #-}

1313#endif

1414

1515module Servant.Server.Internal

@@ -26,9 +26,9 @@ import Control.Monad.Trans.Except (ExceptT)

2626import qualified Data.ByteString as B

2727import qualified Data.ByteString.Lazy as BL

2828import qualified Data.Map as M

29−import Data.Maybe (mapMaybe, fromMaybe)

29+import Data.Maybe (fromMaybe, mapMaybe)

3030import Data.String (fromString)

31−import Data.String.Conversions (cs, (<>), ConvertibleStrings)

31+import Data.String.Conversions (ConvertibleStrings, cs, (<>))

3232import Data.Text (Text)

3333import Data.Typeable

3434import GHC.TypeLits (KnownSymbol, symbolVal)

@@ -46,9 +46,11 @@ import Servant.API ((:<|>) (..), (:>), Capture,

4646 Raw, RemoteHost, ReqBody, Vault)

4747import Servant.API.ContentTypes (AcceptHeader (..),

4848 AllCTRender (..),

49− AllCTUnrender (..))

50−import Servant.API.ResponseHeaders (Headers, getResponse, GetHeaders,

51− getHeaders)

49+ AllCTUnrender (..),

50+ AllMime,

51+ canHandleAcceptH)

52+import Servant.API.ResponseHeaders (GetHeaders, Headers, getHeaders,

53+ getResponse)

5254

5355import Servant.Server.Internal.Router

5456import Servant.Server.Internal.RoutingApplication

@@ -60,7 +62,7 @@ import Web.HttpApiData.Internal (parseUrlPieceMaybe, parseHeaderMaybe,

6062class HasServer layout where

6163 type ServerT layout (m :: * -> *) :: *

6264

63− route :: Proxy layout -> IO (RouteResult (Server layout)) -> Router

65+ route :: Proxy layout -> Delayed (Server layout) -> Router

6466

6567type Server layout = ServerT layout (ExceptT ServantErr IO)

6668

@@ -81,8 +83,8 @@ instance (HasServer a, HasServer b) => HasServer (a :<|> b) where

8183

8284 type ServerT (a :<|> b) m = ServerT a m :<|> ServerT b m

8385

84− route Proxy server = choice (route pa (extractL <$> server))

85− (route pb (extractR <$> server))

86+ route Proxy server = choice (route pa ((\ (a :<|> _) -> a) <$> server))

87+ (route pb ((\ (_ :<|> b) -> b) <$> server))

8688 where pa = Proxy :: Proxy a

8789 pb = Proxy :: Proxy b

8890

@@ -112,13 +114,15 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout)

112114 type ServerT (Capture capture a :> sublayout) m =

113115 a -> ServerT sublayout m

114116

115− route Proxy subserver =

117+ route Proxy d =

116118 DynamicRouter $ \ first ->

117− route (Proxy :: Proxy sublayout)

118− (case captured captureProxy first of

119− Nothing -> return $ failWith NotFound

120− Just v -> feedTo subserver v)

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

119+ route (Proxy :: Proxy sublayout)

120+ (addCapture d $ case captured captureProxy first of

121+ Nothing -> return $ Fail err404

122+ Just v -> return $ Route v

123+ )

124+ where

125+ captureProxy = Proxy :: Proxy (Capture capture a)

122126

123127allowedMethodHead :: Method -> Request -> Bool

124128allowedMethodHead method request = method == methodGet && requestMethod request == methodHead

@@ -131,57 +135,65 @@ processMethodRouter :: forall a. ConvertibleStrings a B.ByteString

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

132136 -> Request -> RouteResult Response

133137processMethodRouter handleA status method headers request = case handleA of

134− Nothing -> failWith UnsupportedMediaType

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

138+ Nothing -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does

139+ Just (contentT, body) -> Route $ responseLBS status hdrs bdy

136140 where

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

138142 hdrs = (hContentType, cs contentT) : (fromMaybe [] headers)

139143

144+methodCheck :: Method -> Request -> IO (RouteResult ())

145+methodCheck method request

146+ | allowedMethod method request = return $ Route ()

147+ | otherwise = return $ Fail err405

148+

149+acceptCheck :: (AllMime list) => Proxy list -> B.ByteString -> IO (RouteResult ())

150+acceptCheck proxy accH

151+ | canHandleAcceptH proxy (AcceptHeader accH) = return $ Route ()

152+ | otherwise = return $ Fail err406

153+

140154methodRouter :: (AllCTRender ctypes a)

141155 => Method -> Proxy ctypes -> Status

142− -> IO (RouteResult (ExceptT ServantErr IO a))

156+ -> Delayed (ExceptT ServantErr IO a)

143157 -> Router

144158methodRouter method proxy status action = LeafRouter route'

145159 where

146160 route' request respond

147− | pathIsEmpty request && allowedMethod method request = do

148− runAction action respond $ \ output -> do

149− let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request

150− handleA = handleAcceptH proxy (AcceptHeader accH) output

151− processMethodRouter handleA status method Nothing request

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

153− respond $ failWith WrongMethod

154− | otherwise = respond $ failWith NotFound

161+ | pathIsEmpty request =

162+ let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request

163+ in runAction (action `addMethodCheck` methodCheck method request

164+ `addAcceptCheck` acceptCheck proxy accH

165+ ) respond $ \ output -> do

166+ let handleA = handleAcceptH proxy (AcceptHeader accH) output

167+ processMethodRouter handleA status method Nothing request

168+ | otherwise = respond $ Fail err404

155169

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

157171 => Method -> Proxy ctypes -> Status

158− -> IO (RouteResult (ExceptT ServantErr IO (Headers h v)))

172+ -> Delayed (ExceptT ServantErr IO (Headers h v))

159173 -> Router

160174methodRouterHeaders method proxy status action = LeafRouter route'

161175 where

162176 route' request respond

163− | pathIsEmpty request && allowedMethod method request = do

164− runAction action respond $ \ output -> do

165− let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request

166− headers = getHeaders output

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

168− processMethodRouter handleA status method (Just headers) request

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

170− respond $ failWith WrongMethod

171− | otherwise = respond $ failWith NotFound

177+ | pathIsEmpty request =

178+ let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request

179+ in runAction (action `addMethodCheck` methodCheck method request

180+ `addAcceptCheck` acceptCheck proxy accH

181+ ) respond $ \ output -> do

182+ let headers = getHeaders output

183+ handleA = handleAcceptH proxy (AcceptHeader accH) (getResponse output)

184+ processMethodRouter handleA status method (Just headers) request

185+ | otherwise = respond $ Fail err404

172186

173187methodRouterEmpty :: Method

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

188+ -> Delayed (ExceptT ServantErr IO ())

175189 -> Router

176190methodRouterEmpty method action = LeafRouter route'

177191 where

178192 route' request respond

179− | pathIsEmpty request && allowedMethod method request = do

180− runAction action respond $ \ () ->

181− succeedWith $ responseLBS noContent204 [] ""

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

183− respond $ failWith WrongMethod

184− | otherwise = respond $ failWith NotFound

193+ | pathIsEmpty request = do

194+ runAction (addMethodCheck action (methodCheck method request)) respond $ \ () ->

195+ Route $! responseLBS noContent204 [] ""

196+ | otherwise = respond $ Fail err404

185197

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

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

@@ -301,7 +313,7 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout)

301313

302314 route Proxy subserver = WithRequest $ \ request ->

303315 let mheader = parseHeaderMaybe =<< lookup str (requestHeaders request)

304− in route (Proxy :: Proxy sublayout) (feedTo subserver mheader)

316+ in route (Proxy :: Proxy sublayout) (passToServer subserver mheader)

305317 where str = fromString $ symbolVal (Proxy :: Proxy sym)

306318

307319-- | When implementing the handler for a 'Post' endpoint,

@@ -473,7 +485,7 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout)

473485 Just Nothing -> Nothing -- param present with no value -> Nothing

474486 Just (Just v) -> parseQueryParamMaybe v -- if present, we try to convert to

475487 -- the right type

476− in route (Proxy :: Proxy sublayout) (feedTo subserver param)

488+ in route (Proxy :: Proxy sublayout) (passToServer subserver param)

477489 where paramname = cs $ symbolVal (Proxy :: Proxy sym)

478490

479491-- | 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)

508520 -- corresponding values

509521 parameters = filter looksLikeParam querytext

510522 values = mapMaybe (convert . snd) parameters

511− in route (Proxy :: Proxy sublayout) (feedTo subserver values)

523+ in route (Proxy :: Proxy sublayout) (passToServer subserver values)

512524 where paramname = cs $ symbolVal (Proxy :: Proxy sym)

513525 looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]")

514526 convert Nothing = Nothing

@@ -538,7 +550,7 @@ instance (KnownSymbol sym, HasServer sublayout)

538550 Just Nothing -> True -- param is there, with no value

539551 Just (Just v) -> examine v -- param with a value

540552 Nothing -> False -- param not in the query string

541− in route (Proxy :: Proxy sublayout) (feedTo subserver param)

553+ in route (Proxy :: Proxy sublayout) (passToServer subserver param)

542554 where paramname = cs $ symbolVal (Proxy :: Proxy sym)

543555 examine v | v == "true" || v == "1" || v == "" = True

544556 | otherwise = False

@@ -556,10 +568,11 @@ instance HasServer Raw where

556568 type ServerT Raw m = Application

557569

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

559− r <- rawApplication

571+ r <- runDelayed rawApplication

560572 case r of

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

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

573+ Route app -> app request (respond . Route)

574+ Fail a -> respond $ Fail a

575+ FailFatal e -> respond $ FailFatal e

563576

564577-- | If you use 'ReqBody' in one of the endpoints for your API,

565578-- this automatically requires your server-side handler to be a function

@@ -589,19 +602,21 @@ instance ( AllCTUnrender list a, HasServer sublayout

589602 a -> ServerT sublayout m

590603

591604 route Proxy subserver = WithRequest $ \ request ->

592− route (Proxy :: Proxy sublayout) $ do

593− -- See HTTP RFC 2616, section 7.2.1

594− -- http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1

595− -- See also "W3C Internet Media Type registration, consistency of use"

596− -- http://www.w3.org/2001/tag/2002/0129-mime

597− let contentTypeH = fromMaybe "application/octet-stream"

598− $ lookup hContentType $ requestHeaders request

599− mrqbody <- handleCTypeH (Proxy :: Proxy list) (cs contentTypeH)

600− <$> lazyRequestBody request

601− case mrqbody of

602− Nothing -> return $ failWith $ UnsupportedMediaType

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

604− Just (Right v) -> feedTo subserver v

605+ route (Proxy :: Proxy sublayout) (addBodyCheck subserver (bodyCheck request))

606+ where

607+ bodyCheck request = do

608+ -- See HTTP RFC 2616, section 7.2.1

609+ -- http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1

610+ -- See also "W3C Internet Media Type registration, consistency of use"

611+ -- http://www.w3.org/2001/tag/2002/0129-mime

612+ let contentTypeH = fromMaybe "application/octet-stream"

613+ $ lookup hContentType $ requestHeaders request

614+ mrqbody <- handleCTypeH (Proxy :: Proxy list) (cs contentTypeH)

615+ <$> lazyRequestBody request

616+ case mrqbody of

617+ Nothing -> return $ FailFatal err415

618+ Just (Left e) -> return $ FailFatal err400 { errBody = cs e }

619+ Just (Right v) -> return $ Route v

605620

606621-- | Make sure the incoming request starts with @"/path"@, strip it and

607622-- pass the rest of the request path to @sublayout@.

@@ -618,13 +633,13 @@ instance HasServer api => HasServer (RemoteHost :> api) where

618633 type ServerT (RemoteHost :> api) m = SockAddr -> ServerT api m

619634

620635 route Proxy subserver = WithRequest $ \req ->

621− route (Proxy :: Proxy api) (feedTo subserver $ remoteHost req)

636+ route (Proxy :: Proxy api) (passToServer subserver $ remoteHost req)

622637

623638instance HasServer api => HasServer (IsSecure :> api) where

624639 type ServerT (IsSecure :> api) m = IsSecure -> ServerT api m

625640

626641 route Proxy subserver = WithRequest $ \req ->

627− route (Proxy :: Proxy api) (feedTo subserver $ secure req)

642+ route (Proxy :: Proxy api) (passToServer subserver $ secure req)

628643

629644 where secure req = if isSecure req then Secure else NotSecure

630645

@@ -632,13 +647,13 @@ instance HasServer api => HasServer (Vault :> api) where

632647 type ServerT (Vault :> api) m = Vault -> ServerT api m

633648

634649 route Proxy subserver = WithRequest $ \req ->

635− route (Proxy :: Proxy api) (feedTo subserver $ vault req)

650+ route (Proxy :: Proxy api) (passToServer subserver $ vault req)

636651

637652instance HasServer api => HasServer (HttpVersion :> api) where

638653 type ServerT (HttpVersion :> api) m = HttpVersion -> ServerT api m

639654

640655 route Proxy subserver = WithRequest $ \req ->

641− route (Proxy :: Proxy api) (feedTo subserver $ httpVersion req)

656+ route (Proxy :: Proxy api) (passToServer subserver $ httpVersion req)

642657

643658pathIsEmpty :: Request -> Bool

644659pathIsEmpty = go . pathInfo

servant-server/src/Servant/Server/Internal/Router.hs+23−9

@@ -1,13 +1,13 @@

11{-# LANGUAGE DeriveFunctor #-}

2−

2+{-# LANGUAGE CPP #-}

33module Servant.Server.Internal.Router where

55import Data.Map (Map)

66import qualified Data.Map as M

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

87import Data.Text (Text)

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

109import Servant.Server.Internal.RoutingApplication

10+import Servant.Server.Internal.ServantErr

1111

1212type Router = Router' RoutingApplication

1313

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

6363 | Just router <- M.lookup first table

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

6565 in runRouter router request' respond

66− _ -> respond $ failWith NotFound

66+ _ -> respond $ Fail err404

6767runRouter (DynamicRouter fun) request respond =

6868 case pathInfo request of

6969 first : rest

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

7171 in runRouter (fun first) request' respond

72− _ -> respond $ failWith NotFound

72+ _ -> respond $ Fail err404

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

7474runRouter (Choice r1 r2) request respond =

75− runRouter r1 request $ \ mResponse1 ->

76− if isMismatch mResponse1

77− then runRouter r2 request $ \ mResponse2 ->

78− respond (mResponse1 <> mResponse2)

79− else respond mResponse1

75+ runRouter r1 request $ \ mResponse1 -> case mResponse1 of

76+ Fail _ -> runRouter r2 request $ \ mResponse2 ->

77+ respond (highestPri mResponse1 mResponse2)

78+ _ -> respond mResponse1

79+ where

80+ highestPri (Fail e1) (Fail e2) =

81+ if worseHTTPCode (errHTTPCode e1) (errHTTPCode e2)

82+ then Fail e2

83+ else Fail e1

84+ highestPri (Fail _) y = y

85+ highestPri x _ = x

86+

87+

88+-- Priority on HTTP codes.

89+--

90+-- It just so happens that 404 < 405 < 406 as far as

91+-- we are concerned here, so we can use (<).

92+worseHTTPCode :: Int -> Int -> Bool

93+worseHTTPCode = (<)

servant-server/src/Servant/Server/Internal/RoutingApplication.hs+194−90

@@ -1,68 +1,37 @@

11{-# LANGUAGE CPP #-}

2−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

2+{-# LANGUAGE DeriveFunctor #-}

33{-# LANGUAGE OverloadedStrings #-}

44{-# LANGUAGE TypeOperators #-}

5+{-# LANGUAGE GADTs #-}

6+{-# LANGUAGE KindSignatures #-}

7+{-# LANGUAGE StandaloneDeriving #-}

58module Servant.Server.Internal.RoutingApplication where

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

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

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

11+import Control.Applicative ((<$>))

1012#endif

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

1214import qualified Data.ByteString as B

1315import qualified Data.ByteString.Lazy as BL

1416import Data.IORef (newIORef, readIORef,

1517 writeIORef)

16−import Data.Maybe (fromMaybe)

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

18−import Data.String (fromString)

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

20− ResponseHeaders)

2118import Network.Wai (Application, Request,

2219 Response, ResponseReceived,

23− requestBody, responseLBS,

20+ requestBody,

2421 strictRequestBody)

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

2622import Servant.Server.Internal.ServantErr

2723

2824type RoutingApplication =

2925 Request -- ^ the request, the field 'pathInfo' may be modified by url routing

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

3127

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

33−newtype RouteResult a =

34− RR { routeResult :: Either RouteMismatch a }

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

36−

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

38−--

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

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

41−instance Monoid (RouteResult a) where

42− mempty = RR $ Left mempty

43−

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

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

46− r `mappend` _ = r

47−

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

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

50−data RouteMismatch =

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

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

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

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

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

56− deriving (Eq, Ord, Show)

57−

58−instance Monoid RouteMismatch where

59− mempty = NotFound

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

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

62− --

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

64− -- arbitrary'" -- William Burroughs

65− mappend = max

28+-- | The result of matching against a path in the route tree.

29+data RouteResult a =

30+ Fail ServantErr -- ^ Keep trying other paths. The @ServantErr@

31+ -- should only be 404, 405 or 406.

32+ | FailFatal !ServantErr -- ^ Don't try other paths.

33+ | Route !a

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

6635

6736data ReqBodyState = Uncalled

6837 | Called !B.ByteString

@@ -91,55 +60,190 @@ toApplication ra request respond = do

9160 writeIORef reqBodyRef $ Called bs

9261 return B.empty

9362

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

63+ ra request{ requestBody = memoReqBody } routingRespond

9564 where

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

97− routingRespond (Left NotFound) =

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

99− routingRespond (Left WrongMethod) =

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

101− routingRespond (Left (InvalidBody err)) =

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

103− routingRespond (Left UnsupportedMediaType) =

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

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

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

107− routingRespond (Right response) =

108− respond response

109−

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

65+ routingRespond :: RouteResult Response -> IO ResponseReceived

66+ routingRespond (Fail err) = respond $ responseServantErr err

67+ routingRespond (FailFatal err) = respond $ responseServantErr err

68+ routingRespond (Route v) = respond v

69+

70+-- We currently mix up the order in which we perform checks

71+-- and the priority with which errors are reported.

72+--

73+-- For example, we perform Capture checks prior to method checks,

74+-- and therefore get 404 before 405.

75+--

76+-- However, we also perform body checks prior to method checks

77+-- now, and therefore get 415 before 405, which is wrong.

78+--

79+-- If we delay Captures, but perform method checks eagerly, we

80+-- end up potentially preferring 405 over 404, whcih is also bad.

81+--

82+-- So in principle, we'd like:

83+--

84+-- static routes (can cause 404)

85+-- delayed captures (can cause 404)

86+-- methods (can cause 405)

87+-- delayed body (can cause 415, 400)

88+-- accept header (can cause 406)

89+--

90+-- According to the HTTP decision diagram, the priority order

91+-- between HTTP status codes is as follows:

92+--

93+

94+-- | A 'Delayed' is a representation of a handler with scheduled

95+-- delayed checks that can trigger errors.

96+--

97+-- Why would we want to delay checks?

98+--

99+-- There are two reasons:

100+--

101+-- 1. Currently, the order in which we perform checks coincides

102+-- with the error we will generate. This is because during checks,

103+-- once an error occurs, we do not perform any subsequent checks,

104+-- but rather return this error.

105+--

106+-- This is not a necessity: we could continue doing other checks,

107+-- and choose the preferred error. However, that would in general

108+-- mean more checking, which leads us to the other reason.

109+--

110+-- 2. We really want to avoid doing certain checks too early. For

111+-- example, captures involve parsing, and are much more costly

112+-- than static route matches. In particular, if several paths

113+-- contain the "same" capture, we'd like as much as possible to

114+-- avoid trying the same parse many times. Also tricky is the

115+-- request body. Again, this involves parsing, but also, WAI makes

116+-- obtaining the request body a side-effecting operation. We

117+-- could/can work around this by manually caching the request body,

118+-- but we'd rather keep the number of times we actually try to

119+-- decode the request body to an absolute minimum.

120+--

121+-- We prefer to have the following relative priorities of error

122+-- codes:

123+--

124+-- @

125+-- 404

126+-- 405 (bad method)

127+-- 401 (unauthorized)

128+-- 415 (unsupported media type)

129+-- 400 (bad request)

130+-- 406 (not acceptable)

131+-- @

132+--

133+-- Therefore, while routing, we delay most checks so that they

134+-- will ultimately occur in the right order.

135+--

136+-- A 'Delayed' contains three delayed blocks of tests, and

137+-- the actual handler:

138+--

139+-- 1. Delayed captures. These can actually cause 404, and

140+-- while they're costly, they should be done first among the

141+-- delayed checks (at least as long as we do not decouple the

142+-- check order from the error reporting, see above). Delayed

143+-- captures can provide inputs to the actual handler.

144+--

145+-- 2. Method check(s). This can cause a 405. On success,

146+-- it does not provide an input for the handler. Method checks

147+-- are comparatively cheap.

148+--

149+-- 3. Body and accept header checks. The request body check can

150+-- cause both 400 and 415. This provides an input to the handler.

151+-- The accept header check can be performed as the final

152+-- computation in this block. It can cause a 406.

153+--

154+data Delayed :: * -> * where

155+ Delayed :: IO (RouteResult a)

156+ -> IO (RouteResult ())

157+ -> IO (RouteResult b)

158+ -> (a -> b -> RouteResult c)

159+ -> Delayed c

160+

161+instance Functor Delayed where

162+ fmap f (Delayed a b c g) = Delayed a b c ((fmap.fmap.fmap) f g)

163+

164+-- | Add a capture to the end of the capture block.

165+addCapture :: Delayed (a -> b)

166+ -> IO (RouteResult a)

167+ -> Delayed b

168+addCapture (Delayed captures method body server) new =

169+ Delayed (combineRouteResults (,) captures new) method body (\ (x, v) y -> ($ v) <$> server x y)

170+

171+-- | Add a method check to the end of the method block.

172+addMethodCheck :: Delayed a

173+ -> IO (RouteResult ())

174+ -> Delayed a

175+addMethodCheck (Delayed captures method body server) new =

176+ Delayed captures (combineRouteResults const method new) body server

177+

178+-- | Add a body check to the end of the body block.

179+addBodyCheck :: Delayed (a -> b)

180+ -> IO (RouteResult a)

181+ -> Delayed b

182+addBodyCheck (Delayed captures method body server) new =

183+ Delayed captures method (combineRouteResults (,) body new) (\ x (y, v) -> ($ v) <$> server x y)

184+

185+-- | Add an accept header check to the end of the body block.

186+-- The accept header check should occur after the body check,

187+-- but this will be the case, because the accept header check

188+-- is only scheduled by the method combinators.

189+addAcceptCheck :: Delayed a

190+ -> IO (RouteResult ())

191+ -> Delayed a

192+addAcceptCheck (Delayed captures method body server) new =

193+ Delayed captures method (combineRouteResults const body new) server

194+

195+-- | Many combinators extract information that is passed to

196+-- the handler without the possibility of failure. In such a

197+-- case, 'passToServer' can be used.

198+passToServer :: Delayed (a -> b) -> a -> Delayed b

199+passToServer d x = ($ x) <$> d

200+

201+-- | The combination 'IO . RouteResult' is a monad, but we

202+-- don't explicitly wrap it in a newtype in order to make it

203+-- an instance. This is the '>>=' of that monad.

204+--

205+-- We stop on the first error.

206+bindRouteResults :: IO (RouteResult a) -> (a -> IO (RouteResult b)) -> IO (RouteResult b)

207+bindRouteResults m f = do

208+ r <- m

209+ case r of

210+ Fail e -> return $ Fail e

211+ FailFatal e -> return $ FailFatal e

212+ Route a -> f a

213+

214+-- | Common special case of 'bindRouteResults', corresponding

215+-- to 'liftM2'.

216+combineRouteResults :: (a -> b -> c) -> IO (RouteResult a) -> IO (RouteResult b) -> IO (RouteResult c)

217+combineRouteResults f m1 m2 =

218+ m1 `bindRouteResults` \ a ->

219+ m2 `bindRouteResults` \ b ->

220+ return (Route (f a b))

221+

222+-- | Run a delayed server. Performs all scheduled operations

223+-- in order, and passes the results from the capture and body

224+-- blocks on to the actual handler.

225+runDelayed :: Delayed a

226+ -> IO (RouteResult a)

227+runDelayed (Delayed captures method body server) =

228+ captures `bindRouteResults` \ c ->

229+ method `bindRouteResults` \ _ ->

230+ body `bindRouteResults` \ b ->

231+ return (server c b)

232+

233+-- | Runs a delayed server and the resulting action.

234+-- Takes a continuation that lets us send a response.

235+-- Also takes a continuation for how to turn the

236+-- result of the delayed server into a response.

237+runAction :: Delayed (ExceptT ServantErr IO a)

111238 -> (RouteResult Response -> IO r)

112239 -> (a -> RouteResult Response)

113240 -> IO r

114−runAction action respond k = do

115− r <- action

116− go r

241+runAction action respond k = runDelayed action >>= go >>= respond

117242 where

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

243+ go (Fail e) = return $ Fail e

244+ go (FailFatal e) = return $ FailFatal e

245+ go (Route a) = do

119246 e <- runExceptT a

120− respond $ case e of

121− Right x -> k x

122− Left err -> succeedWith $ responseServantErr err

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

124−

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

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

127−

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

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

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

131−

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

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

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

135−

136−failWith :: RouteMismatch -> RouteResult a

137−failWith = RR . Left

138−

139−succeedWith :: a -> RouteResult a

140−succeedWith = RR . Right

141−

142−isMismatch :: RouteResult a -> Bool

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

144−isMismatch _ = False

145−

247+ case e of

248+ Left err -> return . Route $ responseServantErr err

249+ Right x -> return $! k x

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

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

1111 , errReasonPhrase :: String

1212 , errBody :: LBS.ByteString

1313 , errHeaders :: [HTTP.Header]

14− } deriving (Show, Eq)

14+ } deriving (Show, Eq, Read)

1515

1616responseServantErr :: ServantErr -> Response

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

servant-server/test/Servant/Server/ErrorSpec.hsnew file+224

@@ -0,0 +1,224 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE MultiParamTypeClasses #-}

3+{-# LANGUAGE OverloadedStrings #-}

4+{-# LANGUAGE TypeOperators #-}

5+{-# OPTIONS_GHC -fno-warn-orphans #-}

6+module Servant.Server.ErrorSpec (spec) where

8+import Control.Monad.Trans.Except (throwE)

9+import Data.Aeson (encode)

10+import qualified Data.ByteString.Char8 as BC

11+import qualified Data.ByteString.Lazy.Char8 as BCL

12+import Data.Proxy

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

14+ methodPost, methodPut)

15+import Safe (readMay)

16+import Test.Hspec

17+import Test.Hspec.Wai

18+

19+import Servant

20+

21+spec :: Spec

22+spec = describe "HTTP Errors" $ do

23+ errorOrderSpec

24+ prioErrorsSpec

25+ errorRetrySpec

26+ errorChoiceSpec

27+

28+------------------------------------------------------------------------------

29+-- * Error Order {{{

30+

31+type ErrorOrderApi = "home"

32+ :> ReqBody '[JSON] Int

33+ :> Capture "t" Int

34+ :> Post '[JSON] Int

35+

36+

37+errorOrderApi :: Proxy ErrorOrderApi

38+errorOrderApi = Proxy

39+

40+errorOrderServer :: Server ErrorOrderApi

41+errorOrderServer = \_ _ -> throwE err402

42+

43+errorOrderSpec :: Spec

44+errorOrderSpec = describe "HTTP error order"

45+ $ with (return $ serve errorOrderApi errorOrderServer) $ do

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

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

48+ badMethod = methodGet

49+ badUrl = "home/nonexistent"

50+ badBody = "nonsense"

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

52+ goodAccept = (hAccept, "application/json")

53+ goodMethod = methodPost

54+ goodUrl = "home/2"

55+ goodBody = encode (5 :: Int)

56+

57+ it "has 404 as its highest priority error" $ do

58+ request badMethod badUrl [badContentType, badAccept] badBody

59+ `shouldRespondWith` 404

60+

61+ it "has 405 as its second highest priority error" $ do

62+ request badMethod goodUrl [badContentType, badAccept] badBody

63+ `shouldRespondWith` 405

64+

65+ it "has 415 as its third highest priority error" $ do

66+ request goodMethod goodUrl [badContentType, badAccept] badBody

67+ `shouldRespondWith` 415

68+

69+ it "has 400 as its fourth highest priority error" $ do

70+ request goodMethod goodUrl [goodContentType, badAccept] badBody

71+ `shouldRespondWith` 400

72+

73+ it "has 406 as its fifth highest priority error" $ do

74+ request goodMethod goodUrl [goodContentType, badAccept] goodBody

75+ `shouldRespondWith` 406

76+

77+ it "has handler-level errors as last priority" $ do

78+ request goodMethod goodUrl [goodContentType, goodAccept] goodBody

79+ `shouldRespondWith` 402

80+

81+type PrioErrorsApi = ReqBody '[JSON] Integer :> "foo" :> Get '[JSON] Integer

82+

83+prioErrorsApi :: Proxy PrioErrorsApi

84+prioErrorsApi = Proxy

85+

86+-- Check whether matching continues even if a 'ReqBody' or similar construct

87+-- is encountered early in a path. We don't want to see a complaint about the

88+-- request body unless the path actually matches.

89+prioErrorsSpec :: Spec

90+prioErrorsSpec = describe "PrioErrors" $ do

91+ let server = return

92+ with (return $ serve prioErrorsApi server) $ do

93+ let check (mdescr, method) path (cdescr, ctype, body) resp =

94+ it fulldescr $

95+ Test.Hspec.Wai.request method path [(hContentType, ctype)] body

96+ `shouldRespondWith` resp

97+ where

98+ fulldescr = "returns " ++ show (matchStatus resp) ++ " on " ++ mdescr

99+ ++ " " ++ BC.unpack path ++ " (" ++ cdescr ++ ")"

100+

101+ get' = ("GET", methodGet)

102+ put' = ("PUT", methodPut)

103+

104+ txt = ("text" , "text/plain;charset=utf8" , "42" )

105+ ijson = ("invalid json", "application/json;charset=utf8", "invalid" )

106+ vjson = ("valid json" , "application/json;charset=utf8", encode (5 :: Int))

107+

108+ check get' "/" txt 404

109+ check get' "/bar" txt 404

110+ check get' "/foo" txt 415

111+ check put' "/" txt 404

112+ check put' "/bar" txt 404

113+ check put' "/foo" txt 405

114+ check get' "/" ijson 404

115+ check get' "/bar" ijson 404

116+ check get' "/foo" ijson 400

117+ check put' "/" ijson 404

118+ check put' "/bar" ijson 404

119+ check put' "/foo" ijson 405

120+ check get' "/" vjson 404

121+ check get' "/bar" vjson 404

122+ check get' "/foo" vjson 200

123+ check put' "/" vjson 404

124+ check put' "/bar" vjson 404

125+ check put' "/foo" vjson 405

126+

127+-- }}}

128+------------------------------------------------------------------------------

129+-- * Error Retry {{{

130+

131+type ErrorRetryApi

132+ = "a" :> ReqBody '[JSON] Int :> Post '[JSON] Int -- err402

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

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

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

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

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

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

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

140+

141+errorRetryApi :: Proxy ErrorRetryApi

142+errorRetryApi = Proxy

143+

144+errorRetryServer :: Server ErrorRetryApi

145+errorRetryServer

146+ = (\_ -> throwE err402)

147+ :<|> (\_ -> return 1)

148+ :<|> (\_ -> return 2)

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

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

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

152+ :<|> (\_ -> return 6)

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

154+

155+errorRetrySpec :: Spec

156+errorRetrySpec = describe "Handler search"

157+ $ with (return $ serve errorRetryApi errorRetryServer) $ do

158+

159+ let jsonCT = (hContentType, "application/json")

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

161+ jsonBody = encode (1797 :: Int)

162+

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

164+ request methodPost "" [jsonCT, jsonAccept] jsonBody

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

166+

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

168+ request methodGet "a" [jsonCT, jsonAccept] jsonBody

169+ `shouldRespondWith` 200 { matchBody = Just $ encode (4 :: Int) }

170+

171+-- }}}

172+------------------------------------------------------------------------------

173+-- * Error Choice {{{

174+

175+type ErrorChoiceApi

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

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

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

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

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

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

182+

183+errorChoiceApi :: Proxy ErrorChoiceApi

184+errorChoiceApi = Proxy

185+

186+errorChoiceServer :: Server ErrorChoiceApi

187+errorChoiceServer = return 0

188+ :<|> return 1

189+ :<|> return 2

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

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

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

193+

194+

195+errorChoiceSpec :: Spec

196+errorChoiceSpec = describe "Multiple handlers return errors"

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

198+

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

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

201+

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

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

204+

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

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

207+ `shouldRespondWith` 415

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

209+ `shouldRespondWith` 400

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

211+ (hAccept, "blah")] "5"

212+ `shouldRespondWith` 406

213+

214+

215+-- }}}

216+------------------------------------------------------------------------------

217+-- * Instances {{{

218+

219+instance MimeUnrender PlainText Int where

220+ mimeUnrender _ x = maybe (Left "no parse") Right (readMay $ BCL.unpack x)

221+

222+instance MimeRender PlainText Int where

223+ mimeRender _ = BCL.pack . show

224+-- }}}

servant-server/test/Servant/ServerSpec.hs+20−118

@@ -1,6 +1,7 @@

11{-# LANGUAGE CPP #-}

22{-# LANGUAGE DataKinds #-}

33{-# LANGUAGE DeriveGeneric #-}

4+{-# LANGUAGE FlexibleInstances #-}

45{-# LANGUAGE OverloadedStrings #-}

56{-# LANGUAGE ScopedTypeVariables #-}

67{-# LANGUAGE TypeOperators #-}

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

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

1819import Data.ByteString.Conversion ()

1920import Data.Char (toUpper)

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

2121import Data.Proxy (Proxy (Proxy))

2222import Data.String (fromString)

2323import Data.String.Conversions (cs)

@@ -26,18 +26,13 @@ import GHC.Generics (Generic)

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

2727 methodDelete, methodGet, methodHead,

2828 methodPatch, methodPost, methodPut,

29− ok200, parseQuery, status409,

30− Status(..))

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

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

3231 queryString, rawQueryString,

3332 responseLBS, responseBuilder)

3433import Network.Wai.Internal (Response(ResponseBuilder))

3534import Network.Wai.Test (defaultRequest, request,

3635 runSession, simpleBody)

37−import Test.Hspec (Spec, describe, it, shouldBe)

38−import Test.Hspec.Wai (get, liftIO, matchHeaders,

39− matchStatus, post, request,

40− shouldRespondWith, with, (<:>))

4136import Servant.API ((:<|>) (..), (:>), Capture, Delete,

4237 Get, Header (..), Headers,

4338 HttpVersion, IsSecure (..), JSON,

@@ -46,12 +41,14 @@ import Servant.API ((:<|>) (..), (:>), Capture, Delete,

4641 Raw, RemoteHost, ReqBody,

4742 addHeader)

4843import Servant.Server (Server, serve, ServantErr(..), err404)

44+import Test.Hspec (Spec, describe, it, shouldBe)

45+import Test.Hspec.Wai (get, liftIO, matchHeaders,

46+ matchStatus, post, request,

47+ shouldRespondWith, with, (<:>))

48+import Servant.Server.Internal.RoutingApplication (toApplication, RouteResult(..))

4949import Servant.Server.Internal.Router

5050 (tweakResponse, runRouter,

5151 Router, Router'(LeafRouter))

52−import Servant.Server.Internal.RoutingApplication

53− (RouteResult(..), RouteMismatch(..),

54− toApplication)

5552

5653

5754-- * test data types

@@ -98,8 +95,6 @@ spec = do

9895 headerSpec

9996 rawSpec

10097 unionSpec

101− prioErrorsSpec

102− errorsSpec

10398 routerSpec

10499 responseHeadersSpec

105100 miscReqCombinatorsSpec

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

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

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

160155

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

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

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

163− `shouldRespondWith` 415

158+ `shouldRespondWith` 406

164159

165160

166161headSpec :: Spec

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

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

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

188183

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

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

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

191− `shouldRespondWith` 415

186+ `shouldRespondWith` 406

192187

193188

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

@@ -264,13 +259,13 @@ queryParamSpec = do

264259 }

265260

266261 let params3'' = "?unknown="

267− response3' <- Network.Wai.Test.request defaultRequest{

262+ response3'' <- Network.Wai.Test.request defaultRequest{

268263 rawQueryString = params3'',

269264 queryString = parseQuery params3'',

270265 pathInfo = ["b"]

271266 }

272267 liftIO $

273− decode' (simpleBody response3') `shouldBe` Just alice{

268+ decode' (simpleBody response3'') `shouldBe` Just alice{

274269 name = "Alice"

275270 }

276271

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

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

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

313308

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

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

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

316311 , "application/nonsense")]

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

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

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

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

355350

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

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

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

358353 , "application/nonsense")]

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

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

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

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

397392

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

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

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

400395 , "application/nonsense")]

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

@@ -524,104 +519,11 @@ responseHeadersSpec = describe "ResponseHeaders" $ do

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

525520 `shouldRespondWith` 404

526521

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

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

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

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

530− `shouldRespondWith` 415

531−

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

533−

534−prioErrorsApi :: Proxy PrioErrorsApi

535−prioErrorsApi = Proxy

536−

537−-- | Test the relative priority of error responses from the server.

538−--

539−-- In particular, we check whether matching continues even if a 'ReqBody'

540−-- or similar construct is encountered early in a path. We don't want to

541−-- see a complaint about the request body unless the path actually matches.

542−--

543−prioErrorsSpec :: Spec

544−prioErrorsSpec = describe "PrioErrors" $ do

545− let server = return . age

546− with (return $ serve prioErrorsApi server) $ do

547− let check (mdescr, method) path (cdescr, ctype, body) resp =

548− it fulldescr $

549− Test.Hspec.Wai.request method path [(hContentType, ctype)] body

550− `shouldRespondWith` resp

551− where

552− fulldescr = "returns " ++ show (matchStatus resp) ++ " on " ++ mdescr

553− ++ " " ++ cs path ++ " (" ++ cdescr ++ ")"

554−

555− get' = ("GET", methodGet)

556− put' = ("PUT", methodPut)

557−

558− txt = ("text" , "text/plain;charset=utf8" , "42" )

559− ijson = ("invalid json", "application/json;charset=utf8", "invalid" )

560− vjson = ("valid json" , "application/json;charset=utf8", encode alice)

561−

562− check get' "/" txt 404

563− check get' "/bar" txt 404

564− check get' "/foo" txt 415

565− check put' "/" txt 404

566− check put' "/bar" txt 404

567− check put' "/foo" txt 405

568− check get' "/" ijson 404

569− check get' "/bar" ijson 404

570− check get' "/foo" ijson 400

571− check put' "/" ijson 404

572− check put' "/bar" ijson 404

573− check put' "/foo" ijson 405

574− check get' "/" vjson 404

575− check get' "/bar" vjson 404

576− check get' "/foo" vjson 200

577− check put' "/" vjson 404

578− check put' "/bar" vjson 404

579− check put' "/foo" vjson 405

580−

581−-- | Test server error functionality.

582−errorsSpec :: Spec

583−errorsSpec = do

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

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

586− let wm = WrongMethod

587− let nf = NotFound

588−

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

590− it "HttpError > *" $ do

591− ib <> he `shouldBe` he

592− wm <> he `shouldBe` he

593− nf <> he `shouldBe` he

594−

595− he <> ib `shouldBe` he

596− he <> wm `shouldBe` he

597− he <> nf `shouldBe` he

598−

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

600− he <> ib `shouldBe` he

601− wm <> ib `shouldBe` ib

602− nf <> ib `shouldBe` ib

603−

604− ib <> he `shouldBe` he

605− ib <> wm `shouldBe` ib

606− ib <> nf `shouldBe` ib

607−

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

609− he <> wm `shouldBe` he

610− ib <> wm `shouldBe` ib

611− nf <> wm `shouldBe` wm

612−

613− wm <> he `shouldBe` he

614− wm <> ib `shouldBe` ib

615− wm <> nf `shouldBe` wm

616−

617− it "* > NotFound" $ do

618− he <> nf `shouldBe` he

619− ib <> nf `shouldBe` ib

620− wm <> nf `shouldBe` wm

621−

622− nf <> he `shouldBe` he

623− nf <> ib `shouldBe` ib

624− nf <> wm `shouldBe` wm

525+ `shouldRespondWith` 406

526+

625527

626528routerSpec :: Spec

627529routerSpec = do

@@ -631,7 +533,7 @@ routerSpec = do

631533

632534 router', router :: Router

633535 router' = tweakResponse (twk <$>) router

634− router = LeafRouter $ \_ cont -> cont (RR . Right $ responseBuilder (Status 201 "") [] "")

536+ router = LeafRouter $ \_ cont -> cont (Route $ responseBuilder (Status 201 "") [] "")

635537

636538 twk :: Response -> Response

637539 twk (ResponseBuilder (Status i s) hs b) = ResponseBuilder (Status (i + 1) s) hs b

servant/CHANGELOG.md+1

@@ -6,6 +6,7 @@ HEAD

66* Add more instances for (:<|>)

77* Use `http-api-data` instead of `Servant.Common.Text`

88* Remove matrix params.

9+* Add PlainText String MimeRender and MimeUnrender instances.

910

10110.4.2

1112-----

servant/src/Servant/API/ContentTypes.hs+29−5

@@ -57,12 +57,14 @@ module Servant.API.ContentTypes

5757 , AcceptHeader(..)

5858 , AllCTRender(..)

5959 , AllCTUnrender(..)

60+ , AllMime(..)

6061 , AllMimeRender(..)

6162 , AllMimeUnrender(..)

6263 , FromFormUrlEncoded(..)

6364 , ToFormUrlEncoded(..)

6465 , IsNonEmpty

6566 , eitherDecodeLenient

67+ , canHandleAcceptH

6668 ) where

6769

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

@@ -80,6 +82,8 @@ import qualified Data.ByteString as BS

8082import Data.ByteString.Lazy (ByteString, fromStrict,

8183 toStrict)

8284import qualified Data.ByteString.Lazy as B

85+import qualified Data.ByteString.Lazy.Char8 as BC

86+import Data.Maybe (isJust)

8387import Data.Monoid

8488import Data.String.Conversions (cs)

8589import qualified Data.Text as TextS

@@ -155,14 +159,13 @@ newtype AcceptHeader = AcceptHeader BS.ByteString

155159class Accept ctype => MimeRender ctype a where

156160 mimeRender :: Proxy ctype -> a -> ByteString

157161

158−class AllCTRender (list :: [*]) a where

162+class (AllMimeRender list a) => AllCTRender (list :: [*]) a where

159163 -- If the Accept header can be matched, returns (Just) a tuple of the

160164 -- Content-Type and response (serialization of @a@ into the appropriate

161165 -- mimetype).

162166 handleAcceptH :: Proxy list -> AcceptHeader -> a -> Maybe (ByteString, ByteString)

163167

164−instance ( AllMimeRender ctyps a, IsNonEmpty ctyps

165− ) => AllCTRender ctyps a where

168+instance (AllMimeRender ctyps a, IsNonEmpty ctyps) => AllCTRender ctyps a where

166169 handleAcceptH _ (AcceptHeader accept) val = M.mapAcceptMedia lkup accept

167170 where pctyps = Proxy :: Proxy ctyps

168171 amrs = allMimeRender pctyps val

@@ -210,11 +213,24 @@ instance ( AllMimeUnrender ctyps a, IsNonEmpty ctyps

210213--------------------------------------------------------------------------

211214-- * Utils (Internal)

212215

216+class AllMime (list :: [*]) where

217+ allMime :: Proxy list -> [M.MediaType]

218+

219+instance AllMime '[] where

220+ allMime _ = []

221+

222+instance (Accept ctyp, AllMime ctyps) => AllMime (ctyp ': ctyps) where

223+ allMime _ = (contentType pctyp):allMime pctyps

224+ where pctyp = Proxy :: Proxy ctyp

225+ pctyps = Proxy :: Proxy ctyps

226+

227+canHandleAcceptH :: AllMime list => Proxy list -> AcceptHeader -> Bool

228+canHandleAcceptH p (AcceptHeader h ) = isJust $ M.matchAccept (allMime p) h

213229

214230--------------------------------------------------------------------------

215231-- Check that all elements of list are instances of MimeRender

216232--------------------------------------------------------------------------

217−class AllMimeRender (list :: [*]) a where

233+class (AllMime list) => AllMimeRender (list :: [*]) a where

218234 allMimeRender :: Proxy list

219235 -> a -- value to serialize

220236 -> [(M.MediaType, ByteString)] -- content-types/response pairs

@@ -238,7 +254,7 @@ instance AllMimeRender '[] a where

238254--------------------------------------------------------------------------

239255-- Check that all elements of list are instances of MimeUnrender

240256--------------------------------------------------------------------------

241−class AllMimeUnrender (list :: [*]) a where

257+class (AllMime list) => AllMimeUnrender (list :: [*]) a where

242258 allMimeUnrender :: Proxy list

243259 -> ByteString

244260 -> [(M.MediaType, Either String a)]

@@ -279,6 +295,10 @@ instance MimeRender PlainText TextL.Text where

279295instance MimeRender PlainText TextS.Text where

280296 mimeRender _ = fromStrict . TextS.encodeUtf8

281297

298+-- | @BC.pack@

299+instance MimeRender PlainText String where

300+ mimeRender _ = BC.pack

301+

282302-- | @id@

283303instance MimeRender OctetStream ByteString where

284304 mimeRender _ = id

@@ -328,6 +348,10 @@ instance MimeUnrender PlainText TextL.Text where

328348instance MimeUnrender PlainText TextS.Text where

329349 mimeUnrender _ = left show . TextS.decodeUtf8' . toStrict

330350

351+-- | @Right . BC.unpack@

352+instance MimeUnrender PlainText String where

353+ mimeUnrender _ = Right . BC.unpack

354+

331355-- | @Right . id@

332356instance MimeUnrender OctetStream ByteString where

333357 mimeUnrender _ = Right . id

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

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

33{-# LANGUAGE DeriveGeneric #-}

44{-# LANGUAGE MultiParamTypeClasses #-}

55{-# LANGUAGE OverloadedStrings #-}

6+{-# LANGUAGE PolyKinds #-}

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

78module Servant.API.ContentTypesSpec where

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

3435spec :: Spec

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

3637

38+ describe "handleAcceptH" $ do

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

40+

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

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

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

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

45+ without wisdom `shouldBe` with wisdom

46+

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

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

49+ s = "cheese" :: String

50+ badCharset s `shouldBe` Nothing

51+

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

3853 let p = Proxy :: Proxy JSON

3954