1398d1f · typeable/servant

git.iko.soy/typeable/servant

More systematic approach to delayed checks.

This introduces a `Delayed` type in `RoutingApplication.hs` that contains a handler together with delayed checks. There are several blocks of delayed checks, so that we can ultimately execute them in the order we desire. The process is documented in more detail in `RoutingApplication.hs`.

commit1398d1f5e1584340d2c0f027892ff4321b06446d authorAndres Loeh <andres@well-typed.com> dateWed 16 Sep 2015, 22:07 (11 years ago) parentccadba8

10 files changed+342−172

compare with master

unifiedsplit

servant-docs/src/Servant/Docs/Internal.hs+19−34 servant-examples/auth-combinator/auth-combinator.hs+10−10 servant-server/servant-server.cabal+1 servant-server/src/Servant/Server.hs+4−1 servant-server/src/Servant/Server/Internal.hs+71−56 servant-server/src/Servant/Server/Internal/Router.hs+16−8 servant-server/src/Servant/Server/Internal/RoutingApplication.hs+180−23 servant-server/test/Servant/Server/ErrorSpec.hs+14−21 servant-server/test/Servant/ServerSpec.hs+7−14 servant/src/Servant/API/ContentTypes.hs+20−5

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+10−10

@@ -10,7 +10,6 @@ import Data.Aeson

1010import Data.ByteString (ByteString)

1111import Data.Text (Text)

1212import GHC.Generics

13−import Network.HTTP.Types

1413import Network.Wai

1514import Network.Wai.Handler.Warp

1615import Servant

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

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

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

3130

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

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

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

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

36− Just v -> do

37− authGranted <- isGoodCookie v

38− if authGranted

39− then a

40− else return $ FailFatal err403 { errBody = "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" }

4141

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

4343

servant-server/servant-server.cabal+1

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

108108 , network >= 2.6

109109 , QuickCheck

110110 , parsec

111+ , safe

111112 , servant

112113 , servant-server

113114 , 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 (Route 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+71−56

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

4646 Raw, RemoteHost, ReqBody, Vault)

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

4848 AllCTRender (..),

49− AllCTUnrender (..))

49+ AllCTUnrender (..),

50+ AllMime,

51+ canHandleAcceptH)

5052import Servant.API.ResponseHeaders (GetHeaders, Headers, getHeaders,

5153 getResponse)

5254

@@ -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,12 +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 =

116− DynamicRouter $ \ first -> case captured captureProxy first of

117− Nothing -> LeafRouter (\_ r -> r $ Fail err404)

118− Just v -> route (Proxy :: Proxy sublayout) (feedTo subserver v)

119−

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

117+ route Proxy d =

118+ DynamicRouter $ \ first ->

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)

121126

122127allowedMethodHead :: Method -> Request -> Bool

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

@@ -130,56 +135,64 @@ processMethodRouter :: forall a. ConvertibleStrings a B.ByteString

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

131136 -> Request -> RouteResult Response

132137processMethodRouter handleA status method headers request = case handleA of

133− Nothing -> FailFatal err406

134− Just (contentT, body) -> Route $! 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

135140 where

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

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

138143

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+

139154methodRouter :: (AllCTRender ctypes a)

140155 => Method -> Proxy ctypes -> Status

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

156+ -> Delayed (ExceptT ServantErr IO a)

142157 -> Router

143158methodRouter method proxy status action = LeafRouter route'

144159 where

145160 route' request respond

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

147− runAction action respond $ \ output -> do

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

149− handleA = handleAcceptH proxy (AcceptHeader accH) output

150− processMethodRouter handleA status method Nothing request

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

152− respond $ Fail err405

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

153168 | otherwise = respond $ Fail err404

154169

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

156171 => Method -> Proxy ctypes -> Status

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

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

158173 -> Router

159174methodRouterHeaders method proxy status action = LeafRouter route'

160175 where

161176 route' request respond

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

163− runAction action respond $ \ output -> do

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

165− headers = getHeaders output

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

167− processMethodRouter handleA status method (Just headers) request

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

169− respond $ Fail err405

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

170185 | otherwise = respond $ Fail err404

171186

172187methodRouterEmpty :: Method

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

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

174189 -> Router

175190methodRouterEmpty method action = LeafRouter route'

176191 where

177192 route' request respond

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

179− runAction action respond $ \ () ->

193+ | pathIsEmpty request = do

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

180195 Route $! responseLBS noContent204 [] ""

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

182− respond $ Fail err405

183196 | otherwise = respond $ Fail err404

184197

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

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

300313

301314 route Proxy subserver = WithRequest $ \ request ->

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

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

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

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

305318

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

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

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

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

474487 -- the right type

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

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

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

477490

478491-- | If you use @'QueryParams' "authors" Text@ in one of the endpoints for your API,

@@ -507,7 +520,7 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout)

507520 -- corresponding values

508521 parameters = filter looksLikeParam querytext

509522 values = mapMaybe (convert . snd) parameters

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

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

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

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

513526 convert Nothing = Nothing

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

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

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

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

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

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

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

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

543556 | otherwise = False

@@ -555,7 +568,7 @@ instance HasServer Raw where

555568 type ServerT Raw m = Application

556569

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

558− r <- rawApplication

571+ r <- runDelayed rawApplication

559572 case r of

560573 Route app -> app request (respond . Route)

561574 Fail a -> respond $ Fail a

@@ -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 $ FailFatal err415

603− Just (Left e) -> return $ FailFatal err400 { errBody = cs 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+16−8

@@ -6,9 +6,9 @@ import Data.Map (Map)

66import qualified Data.Map as M

77import Data.Text (Text)

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

9−import Servant.Server.Internal.ServantErr

109import Servant.Server.Internal.PathInfo

1110import Servant.Server.Internal.RoutingApplication

11+import Servant.Server.Internal.ServantErr

1212

1313type Router = Router' RoutingApplication

1414

@@ -77,10 +77,18 @@ runRouter (Choice r1 r2) request respond =

7777 Fail _ -> runRouter r2 request $ \ mResponse2 ->

7878 respond (highestPri mResponse1 mResponse2)

7979 _ -> respond mResponse1

80− where

81− highestPri (Fail e1) (Fail e2) =

82− if errHTTPCode e1 == 404 && errHTTPCode e2 /= 404

83− then Fail e2

84− else Fail e1

85− highestPri (Fail _) y = y

86− highestPri x _ = x

80+ where

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

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

83+ then Fail e2

84+ else Fail e1

85+ highestPri (Fail _) y = y

86+ highestPri x _ = x

87+

88+

89+-- Priority on HTTP codes.

90+--

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

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

93+worseHTTPCode :: Int -> Int -> Bool

94+worseHTTPCode = (<)

servant-server/src/Servant/Server/Internal/RoutingApplication.hs+180−23

@@ -2,6 +2,9 @@

22{-# 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)

@@ -18,19 +21,18 @@ import Network.Wai (Application, Request,

1821 Response, ResponseReceived,

1922 requestBody,

2023 strictRequestBody)

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

2224import Servant.Server.Internal.ServantErr

2325

2426type RoutingApplication =

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

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

2729

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

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

2931data RouteResult a =

3032 Fail ServantErr -- ^ Keep trying other paths. The @ServantErr@

31− -- should only be 404 or 405.

32− | FailFatal ServantErr -- ^ Don't other paths.

33− | Route a

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

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

35+ | Route !a

3436 deriving (Eq, Show, Read, Functor)

3537

3638data ReqBodyState = Uncalled

@@ -63,15 +65,183 @@ toApplication ra request respond = do

6365 ra request{ requestBody = memoReqBody } routingRespond

6466 where

6567 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

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

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

70+ routingRespond (Route v) = respond v

6971

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

72+-- TODO: The above may not be quite right yet.

73+--

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

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

76+--

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

78+-- and therefore get 404 before 405.

79+--

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

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

82+--

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

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

85+--

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

87+--

88+-- static routes (can cause 404)

89+-- delayed captures (can cause 404)

90+-- methods (can cause 405)

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

92+-- accept header (can cause 406)

93+--

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

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

96+--

97+

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

99+-- delayed checks that can trigger errors.

100+--

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

102+--

103+-- There are two reasons:

104+--

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

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

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

108+-- but rather return this error.

109+--

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

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

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

113+--

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

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

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

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

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

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

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

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

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

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

124+--

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

126+-- codes:

127+--

128+-- @

129+-- 404

130+-- 405 (bad method)

131+-- 401 (unauthorized)

132+-- 415 (unsupported media type)

133+-- 400 (bad request)

134+-- 406 (not acceptable)

135+-- @

136+--

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

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

139+--

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

141+-- the actual handler:

142+--

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

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

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

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

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

148+--

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

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

151+-- are comparatively cheap.

152+--

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

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

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

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

157+--

158+data Delayed :: * -> * where

159+ Delayed :: IO (RouteResult a)

160+ -> IO (RouteResult ())

161+ -> IO (RouteResult b)

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

163+ -> Delayed c

164+

165+deriving instance Functor Delayed

166+

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

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

169+ -> IO (RouteResult a)

170+ -> Delayed b

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

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

173+

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

175+addMethodCheck :: Delayed a

176+ -> IO (RouteResult ())

177+ -> Delayed a

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

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

180+

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

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

183+ -> IO (RouteResult a)

184+ -> Delayed b

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

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

187+

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

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

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

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

192+addAcceptCheck :: Delayed a

193+ -> IO (RouteResult ())

194+ -> Delayed a

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

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

197+

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

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

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

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

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

203+

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

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

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

207+--

208+-- We stop on the first error.

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

210+bindRouteResults m f = do

211+ r <- m

212+ case r of

213+ Fail e -> return $ Fail e

214+ FailFatal e -> return $ FailFatal e

215+ Route a -> f a

216+

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

218+-- to 'liftM2'.

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

220+combineRouteResults f m1 m2 =

221+ m1 `bindRouteResults` \ a ->

222+ m2 `bindRouteResults` \ b ->

223+ return (Route (f a b))

224+

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

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

227+-- blocks on to the actual handler.

228+runDelayed :: Delayed a

229+ -> IO (RouteResult a)

230+runDelayed (Delayed captures method body server) =

231+ captures `bindRouteResults` \ c ->

232+ method `bindRouteResults` \ _ ->

233+ body `bindRouteResults` \ b ->

234+ return (server c b)

235+

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

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

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

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

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

71241 -> (RouteResult Response -> IO r)

72242 -> (a -> RouteResult Response)

73243 -> IO r

74−runAction action respond k = action >>= go >>= respond

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

75245 where

76246 go (Fail e) = return $ Fail e

77247 go (FailFatal e) = return $ FailFatal e

@@ -80,16 +250,3 @@ runAction action respond k = action >>= go >>= respond

80250 case e of

81251 Left err -> return . Route $ responseServantErr err

82252 Right x -> return $! k x

83−

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

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

86−

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

88−extractL (Route (a :<|> _)) = Route a

89−extractL (Fail x) = Fail x

90−extractL (FailFatal x) = FailFatal x

91−

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

93−extractR (Route (_ :<|> b)) = Route b

94−extractR (Fail x) = Fail x

95−extractR (FailFatal x) = FailFatal x

servant-server/test/Servant/Server/ErrorSpec.hs+14−21

@@ -5,12 +5,14 @@

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

66module Servant.Server.ErrorSpec (spec) where

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

89import Data.Aeson (encode)

9−import qualified Data.ByteString.Lazy.Char8 as BCL

1010import qualified Data.ByteString.Char8 as BC

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

1112import Data.Proxy

1213import Network.HTTP.Types (hAccept, hContentType, methodGet,

1314 methodPost, methodPut)

15+import Safe (readMay)

1416import Test.Hspec

1517import Test.Hspec.Wai

1618

@@ -54,7 +56,7 @@ errorOrderApi :: Proxy ErrorOrderApi

5456errorOrderApi = Proxy

5557

5658errorOrderServer :: Server ErrorOrderApi

57−errorOrderServer = \_ _ -> return 5

59+errorOrderServer = \_ _ -> throwE err402

5860

5961errorOrderSpec :: Spec

6062errorOrderSpec = describe "HTTP error order"

@@ -65,6 +67,7 @@ errorOrderSpec = describe "HTTP error order"

6567 badUrl = "home/nonexistent"

6668 badBody = "nonsense"

6769 goodContentType = (hContentType, "application/json")

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

6871 goodMethod = methodPost

6972 goodUrl = "home/2"

7073 goodBody = encode (5 :: Int)

@@ -89,6 +92,10 @@ errorOrderSpec = describe "HTTP error order"

8992 request goodMethod goodUrl [goodContentType, badAccept] goodBody

9093 `shouldRespondWith` 406

9194

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

96+ request goodMethod goodUrl [goodContentType, goodAccept] goodBody

97+ `shouldRespondWith` 402

98+

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

93100

94101prioErrorsApi :: Proxy PrioErrorsApi

@@ -107,7 +114,7 @@ prioErrorsSpec = describe "PrioErrors" $ do

107114 `shouldRespondWith` resp

108115 where

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

110− ++ " " ++ (BC.unpack path) ++ " (" ++ cdescr ++ ")"

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

111118

112119 get' = ("GET", methodGet)

113120 put' = ("PUT", methodPut)

@@ -140,7 +147,7 @@ prioErrorsSpec = describe "PrioErrors" $ do

140147-- * Error Retry {{{

141148

142149type ErrorRetryApi

143− = "a" :> ReqBody '[JSON] Int :> Post '[JSON] Int -- 0

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

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

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

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

@@ -154,7 +161,7 @@ errorRetryApi = Proxy

154161

155162errorRetryServer :: Server ErrorRetryApi

156163errorRetryServer

157− = (\_ -> return 0)

164+ = (\_ -> throwE err402)

158165 :<|> (\_ -> return 1)

159166 :<|> (\_ -> return 2)

160167 :<|> (\_ -> return 3)

@@ -181,18 +188,6 @@ errorRetrySpec = describe "Handler search"

181188 request methodGet "a" [jsonCT, jsonAccept] jsonBody

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

183190

184− it "should not continue when Content-Types don't match" $ do

185− request methodPost "a" [plainCT, jsonAccept] jsonBody

186− `shouldRespondWith` 415

187−

188− it "should not continue when body can't be deserialized" $ do

189− request methodPost "a" [jsonCT, jsonAccept] (encode ("nonsense" :: String))

190− `shouldRespondWith` 400

191−

192− it "should not continue when Accepts don't match" $ do

193− request methodPost "a" [jsonCT, plainAccept] jsonBody

194− `shouldRespondWith` 406

195−

196191-- }}}

197192------------------------------------------------------------------------------

198193-- * Error Choice {{{

@@ -233,7 +228,7 @@ errorChoiceSpec = describe "Multiple handlers return errors"

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

234229 `shouldRespondWith` 400

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

236− (hAccept, "application/json")] ""

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

237232 `shouldRespondWith` 406

238233

239234

@@ -242,10 +237,8 @@ errorChoiceSpec = describe "Multiple handlers return errors"

242237-- * Instances {{{

243238

244239instance MimeUnrender PlainText Int where

245− mimeUnrender _ = Right . read . BCL.unpack

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

246241

247242instance MimeRender PlainText Int where

248243 mimeRender _ = BCL.pack . show

249244-- }}}

250−--

251−

servant-server/test/Servant/ServerSpec.hs+7−14

@@ -1,20 +1,12 @@

1−<<<<<<< HEAD

21{-# LANGUAGE CPP #-}

32{-# LANGUAGE DataKinds #-}

43{-# LANGUAGE DeriveGeneric #-}

5−=======

6−{-# LANGUAGE DataKinds #-}

7−{-# LANGUAGE DeriveGeneric #-}

84{-# LANGUAGE FlexibleInstances #-}

9−>>>>>>> Review fixes

105{-# LANGUAGE OverloadedStrings #-}

116{-# LANGUAGE ScopedTypeVariables #-}

127{-# LANGUAGE TypeOperators #-}

138{-# LANGUAGE TypeSynonymInstances #-}

14−<<<<<<< HEAD

159{-# LANGUAGE FlexibleInstances #-}

16−=======

17−>>>>>>> Review fixes

1810

1911module Servant.ServerSpec where

2012

@@ -55,6 +47,7 @@ import Test.Hspec (Spec, describe, it, shouldBe)

5547import Test.Hspec.Wai (get, liftIO, matchHeaders,

5648 matchStatus, post, request,

5749 shouldRespondWith, with, (<:>))

50+<<<<<<< HEAD

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

5952 Get, Header (..), Headers,

6053 HttpVersion, IsSecure (..), JSON,

@@ -63,12 +56,12 @@ import Servant.API ((:<|>) (..), (:>), Capture, Delete,

6356 Raw, RemoteHost, ReqBody,

6457 addHeader)

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

59+=======

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

61+>>>>>>> Rebase cleanup and test fixes.

6662import Servant.Server.Internal.Router

6763 (tweakResponse, runRouter,

6864 Router, Router'(LeafRouter))

69−import Servant.Server.Internal.RoutingApplication

70− (RouteResult(..), RouteMismatch(..),

71− toApplication)

7265

7366

7467-- * test data types

@@ -279,13 +272,13 @@ queryParamSpec = do

279272 }

280273

281274 let params3'' = "?unknown="

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

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

283276 rawQueryString = params3'',

284277 queryString = parseQuery params3'',

285278 pathInfo = ["b"]

286279 }

287280 liftIO $

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

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

289282 name = "Alice"

290283 }

291284

@@ -553,7 +546,7 @@ routerSpec = do

553546

554547 router', router :: Router

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

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

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

557550

558551 twk :: Response -> Response

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

servant/src/Servant/API/ContentTypes.hs+20−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)

@@ -81,6 +83,7 @@ import Data.ByteString.Lazy (ByteString, fromStrict,

8183 toStrict)

8284import qualified Data.ByteString.Lazy as B

8385import qualified Data.ByteString.Lazy.Char8 as BC

86+import Data.Maybe (isJust)

8487import Data.Monoid

8588import Data.String.Conversions (cs)

8689import qualified Data.Text as TextS

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

156159class Accept ctype => MimeRender ctype a where

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

158161

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

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

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

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

162165 -- mimetype).

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

164167

165−instance ( AllMimeRender ctyps a, IsNonEmpty ctyps

166− ) => AllCTRender ctyps a where

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

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

168170 where pctyps = Proxy :: Proxy ctyps

169171 amrs = allMimeRender pctyps val

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

211213--------------------------------------------------------------------------

212214-- * Utils (Internal)

213215

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

214229

215230--------------------------------------------------------------------------

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

217232--------------------------------------------------------------------------

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

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

219234 allMimeRender :: Proxy list

220235 -> a -- value to serialize

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

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

239254--------------------------------------------------------------------------

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

241256--------------------------------------------------------------------------

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

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

243258 allMimeUnrender :: Proxy list

244259 -> ByteString

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