1398d1f · typeable/servant

git.iko.soy/typeable/servant

on master help sign in

More systematic approach to delayed checks.

1398d1fAndres Loeh11 years ago

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

compare with master

unifiedsplit

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

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

497 in concatMap enc samples'

498

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−

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

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

513-- for GET parameters.

500-- for GET parameters.

514--

501--

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

709#if MIN_VERSION_base(4,8,0)

696#if MIN_VERSION_base(4,8,0)

710 {-# OVERLAPPABLe #-}

697 {-# OVERLAPPABLe #-}

711#endif

698#endif

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

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

713 => HasDocs (Delete cts a) where

700 => HasDocs (Delete cts a) where

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

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

715 single endpoint' action'

702 single endpoint' action'

716

703

717 where endpoint' = endpoint & method .~ DocDELETE

704 where endpoint' = endpoint & method .~ DocDELETE

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

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

719− & response.respTypes .~ supportedTypes t

706+ & response.respTypes .~ allMime t

720 t = Proxy :: Proxy cts

707 t = Proxy :: Proxy cts

721 p = Proxy :: Proxy a

708 p = Proxy :: Proxy a

722

709

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

724#if MIN_VERSION_base(4,8,0)

711#if MIN_VERSION_base(4,8,0)

725 {-# OVERLAPPING #-}

712 {-# OVERLAPPING #-}

726#endif

713#endif

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

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

728 , AllHeaderSamples ls , GetHeaders (HList ls) )

715 , AllHeaderSamples ls , GetHeaders (HList ls) )

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

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

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

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

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

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

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

734 endpoint' = endpoint & method .~ DocDELETE

721 endpoint' = endpoint & method .~ DocDELETE

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

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

736− & response.respTypes .~ supportedTypes t

723+ & response.respTypes .~ allMime t

737 & response.respHeaders .~ hdrs

724 & response.respHeaders .~ hdrs

738 t = Proxy :: Proxy cts

725 t = Proxy :: Proxy cts

739 p = Proxy :: Proxy a

726 p = Proxy :: Proxy a

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

742#if MIN_VERSION_base(4,8,0)

729#if MIN_VERSION_base(4,8,0)

743 {-# OVERLAPPABLe #-}

730 {-# OVERLAPPABLe #-}

744#endif

731#endif

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

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

746 => HasDocs (Get cts a) where

733 => HasDocs (Get cts a) where

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

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

748 single endpoint' action'

735 single endpoint' action'

749

736

750 where endpoint' = endpoint & method .~ DocGET

737 where endpoint' = endpoint & method .~ DocGET

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

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

752− & response.respTypes .~ supportedTypes t

739+ & response.respTypes .~ allMime t

753 t = Proxy :: Proxy cts

740 t = Proxy :: Proxy cts

754 p = Proxy :: Proxy a

741 p = Proxy :: Proxy a

755

742

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

757#if MIN_VERSION_base(4,8,0)

744#if MIN_VERSION_base(4,8,0)

758 {-# OVERLAPPING #-}

745 {-# OVERLAPPING #-}

759#endif

746#endif

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

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

761 , AllHeaderSamples ls , GetHeaders (HList ls) )

748 , AllHeaderSamples ls , GetHeaders (HList ls) )

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

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

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

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

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

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

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

767 endpoint' = endpoint & method .~ DocGET

754 endpoint' = endpoint & method .~ DocGET

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

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

769− & response.respTypes .~ supportedTypes t

756+ & response.respTypes .~ allMime t

770 & response.respHeaders .~ hdrs

757 & response.respHeaders .~ hdrs

771 t = Proxy :: Proxy cts

758 t = Proxy :: Proxy cts

772 p = Proxy :: Proxy a

759 p = Proxy :: Proxy a

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

784#if MIN_VERSION_base(4,8,0)

771#if MIN_VERSION_base(4,8,0)

785 {-# OVERLAPPABLE #-}

772 {-# OVERLAPPABLE #-}

786#endif

773#endif

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

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

788 => HasDocs (Post cts a) where

775 => HasDocs (Post cts a) where

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

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

790 single endpoint' action'

777 single endpoint' action'

791

778

792 where endpoint' = endpoint & method .~ DocPOST

779 where endpoint' = endpoint & method .~ DocPOST

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

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

794− & response.respTypes .~ supportedTypes t

781+ & response.respTypes .~ allMime t

795 & response.respStatus .~ 201

782 & response.respStatus .~ 201

796 t = Proxy :: Proxy cts

783 t = Proxy :: Proxy cts

797 p = Proxy :: Proxy a

784 p = Proxy :: Proxy a

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

800#if MIN_VERSION_base(4,8,0)

787#if MIN_VERSION_base(4,8,0)

801 {-# OVERLAPPING #-}

788 {-# OVERLAPPING #-}

802#endif

789#endif

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

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

804 , AllHeaderSamples ls , GetHeaders (HList ls) )

791 , AllHeaderSamples ls , GetHeaders (HList ls) )

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

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

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

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

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

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

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

810 endpoint' = endpoint & method .~ DocPOST

797 endpoint' = endpoint & method .~ DocPOST

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

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

812− & response.respTypes .~ supportedTypes t

799+ & response.respTypes .~ allMime t

813 & response.respStatus .~ 201

800 & response.respStatus .~ 201

814 & response.respHeaders .~ hdrs

801 & response.respHeaders .~ hdrs

815 t = Proxy :: Proxy cts

802 t = Proxy :: Proxy cts

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

819#if MIN_VERSION_base(4,8,0)

806#if MIN_VERSION_base(4,8,0)

820 {-# OVERLAPPABLE #-}

807 {-# OVERLAPPABLE #-}

821#endif

808#endif

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

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

823 => HasDocs (Put cts a) where

810 => HasDocs (Put cts a) where

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

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

825 single endpoint' action'

812 single endpoint' action'

826

813

827 where endpoint' = endpoint & method .~ DocPUT

814 where endpoint' = endpoint & method .~ DocPUT

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

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

829− & response.respTypes .~ supportedTypes t

816+ & response.respTypes .~ allMime t

830 & response.respStatus .~ 200

817 & response.respStatus .~ 200

831 t = Proxy :: Proxy cts

818 t = Proxy :: Proxy cts

832 p = Proxy :: Proxy a

819 p = Proxy :: Proxy a

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

835#if MIN_VERSION_base(4,8,0)

822#if MIN_VERSION_base(4,8,0)

836 {-# OVERLAPPING #-}

823 {-# OVERLAPPING #-}

837#endif

824#endif

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

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

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

826+ AllHeaderSamples ls , GetHeaders (HList ls) )

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

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

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

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

842 single endpoint' action'

829 single endpoint' action'

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

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

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

845 endpoint' = endpoint & method .~ DocPUT

832 endpoint' = endpoint & method .~ DocPUT

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

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

847− & response.respTypes .~ supportedTypes t

834+ & response.respTypes .~ allMime t

848 & response.respStatus .~ 200

835 & response.respStatus .~ 200

849 & response.respHeaders .~ hdrs

836 & response.respHeaders .~ hdrs

850 t = Proxy :: Proxy cts

837 t = Proxy :: Proxy cts

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

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

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

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

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

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

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

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

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

894− , SupportedTypes cts)

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

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

896

882

897 docsFor Proxy (endpoint, action) =

883 docsFor Proxy (endpoint, action) =

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

899

885

900 where sublayoutP = Proxy :: Proxy sublayout

886 where sublayoutP = Proxy :: Proxy sublayout

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

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

902− & rqtypes .~ supportedTypes t

888+ & rqtypes .~ allMime t

903 t = Proxy :: Proxy cts

889 t = Proxy :: Proxy cts

904 p = Proxy :: Proxy a

890 p = Proxy :: Proxy a

905

891

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

957instance ToSample a => ToSample (First a)

943instance ToSample a => ToSample (First a)

958instance ToSample a => ToSample (Last a)

944instance ToSample a => ToSample (Last a)

959instance ToSample a => ToSample (Dual a)

945instance ToSample a => ToSample (Dual a)

960−

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

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

10import Data.ByteString (ByteString)

11import Data.Text (Text)

12import GHC.Generics

13−import Network.HTTP.Types

14import Network.Wai

13import Network.Wai

15import Network.Wai.Handler.Warp

14import Network.Wai.Handler.Warp

16import Servant

15import Servant

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

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

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

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

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

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

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

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

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

33+ where

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

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

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

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

36− Just v -> do

36+ Just v -> do

37− authGranted <- isGoodCookie v

37+ authGranted <- isGoodCookie v

38− if authGranted

38+ if authGranted

39− then a

39+ then return $ Route ()

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

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

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

servant-server/servant-server.cabal+1

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

108 , network >= 2.6

109 , QuickCheck

110 , parsec

111+ , safe

111 , servant

112 , servant

112 , servant-server

113 , servant-server

113 , string-conversions

114 , string-conversions

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

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

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

104--

105serve :: 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 ())

107

110

108

111

109-- Documentation

112-- Documentation

servant-server/src/Servant/Server/Internal.hs+71−56

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

46 Raw, RemoteHost, ReqBody, Vault)

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

48 AllCTRender (..),

49− AllCTUnrender (..))

49+ AllCTUnrender (..),

50+ AllMime,

51+ canHandleAcceptH)

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

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

51 getResponse)

53 getResponse)

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

60class HasServer layout where

62class HasServer layout where

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

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

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

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

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

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

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

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

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

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

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

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

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

86 where pa = Proxy :: Proxy a

88 where pa = Proxy :: Proxy a

87 pb = Proxy :: Proxy b

89 pb = Proxy :: Proxy b

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

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

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

113 a -> ServerT sublayout m

115 a -> ServerT sublayout m

114

116

115− route Proxy subserver =

117+ route Proxy d =

118+ DynamicRouter $ \ first ->

119+ route (Proxy :: Proxy sublayout)

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

120+ (addCapture d $ case captured captureProxy first of

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

121+ Nothing -> return $ Fail err404

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

122+ Just v -> return $ Route v

119−

123+ )

124+ where

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

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

121

126

122allowedMethodHead :: Method -> Request -> Bool

127allowedMethodHead :: Method -> Request -> Bool

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

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

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

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

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

131 -> Request -> RouteResult Response

136 -> Request -> RouteResult Response

132processMethodRouter handleA status method headers request = case handleA of

137processMethodRouter handleA status method headers request = case handleA of

133− Nothing -> FailFatal err406

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

134− Just (contentT, body) -> Route $! responseLBS status hdrs bdy

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

135 where

140 where

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

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

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

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

138

143

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+

139methodRouter :: (AllCTRender ctypes a)

154methodRouter :: (AllCTRender ctypes a)

140 => Method -> Proxy ctypes -> Status

155 => Method -> Proxy ctypes -> Status

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

156+ -> Delayed (ExceptT ServantErr IO a)

142 -> Router

157 -> Router

143methodRouter method proxy status action = LeafRouter route'

158methodRouter method proxy status action = LeafRouter route'

144 where

159 where

145 route' request respond

160 route' request respond

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

161+ | pathIsEmpty request =

147− runAction action respond $ \ output -> do

148− let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders 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

149− handleA = handleAcceptH proxy (AcceptHeader accH) output

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

150− processMethodRouter handleA status method Nothing request

167+ processMethodRouter handleA status method Nothing request

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

152− respond $ Fail err405

153 | otherwise = respond $ Fail err404

168 | otherwise = respond $ Fail err404

154

169

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

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

156 => Method -> Proxy ctypes -> Status

171 => Method -> Proxy ctypes -> Status

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

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

158 -> Router

173 -> Router

159methodRouterHeaders method proxy status action = LeafRouter route'

174methodRouterHeaders method proxy status action = LeafRouter route'

160 where

175 where

161 route' request respond

176 route' request respond

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

177+ | pathIsEmpty request =

163− runAction action respond $ \ output -> do

164− let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders 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

165− headers = getHeaders output

182+ let headers = getHeaders output

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

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

167− processMethodRouter handleA status method (Just headers) request

184+ processMethodRouter handleA status method (Just headers) request

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

169− respond $ Fail err405

170 | otherwise = respond $ Fail err404

185 | otherwise = respond $ Fail err404

171

186

172methodRouterEmpty :: Method

187methodRouterEmpty :: Method

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

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

174 -> Router

189 -> Router

175methodRouterEmpty method action = LeafRouter route'

190methodRouterEmpty method action = LeafRouter route'

176 where

191 where

177 route' request respond

192 route' request respond

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

193+ | pathIsEmpty request = do

179− runAction action respond $ \ () ->

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

180 Route $! responseLBS noContent204 [] ""

195 Route $! responseLBS noContent204 [] ""

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

182− respond $ Fail err405

183 | otherwise = respond $ Fail err404

196 | otherwise = respond $ Fail err404

184

197

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

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

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

300

313

301 route Proxy subserver = WithRequest $ \ request ->

314 route Proxy subserver = WithRequest $ \ request ->

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

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

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

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

305

318

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

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

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

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

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

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

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

474 -- the right type

487 -- the right type

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

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

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

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

477

490

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

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

507 -- corresponding values

520 -- corresponding values

508 parameters = filter looksLikeParam querytext

521 parameters = filter looksLikeParam querytext

509 values = mapMaybe (convert . snd) parameters

522 values = mapMaybe (convert . snd) parameters

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

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

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

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

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

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

513 convert Nothing = Nothing

526 convert Nothing = Nothing

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

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

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

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

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

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

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

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

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

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

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

543 | otherwise = False

556 | otherwise = False

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

555 type ServerT Raw m = Application

568 type ServerT Raw m = Application

556

569

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

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

558− r <- rawApplication

571+ r <- runDelayed rawApplication

559 case r of

572 case r of

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

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

561 Fail a -> respond $ Fail a

574 Fail a -> respond $ Fail a

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

589 a -> ServerT sublayout m

602 a -> ServerT sublayout m

590

603

591 route Proxy subserver = WithRequest $ \ request ->

604 route Proxy subserver = WithRequest $ \ request ->

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

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

606+ where

607+ bodyCheck request = do

593− -- See HTTP RFC 2616, section 7.2.1

608+ -- See HTTP RFC 2616, section 7.2.1

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

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

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

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

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

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

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

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

598− $ lookup hContentType $ requestHeaders request

613+ $ lookup hContentType $ requestHeaders request

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

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

600− <$> lazyRequestBody request

615+ <$> lazyRequestBody request

601− case mrqbody of

616+ case mrqbody of

602− Nothing -> return $ FailFatal err415

617+ Nothing -> return $ FailFatal err415

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

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

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

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

605

620

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

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

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

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

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

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

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

619

634

620 route Proxy subserver = WithRequest $ \req ->

635 route Proxy subserver = WithRequest $ \req ->

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

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

622

637

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

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

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

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

625

640

626 route Proxy subserver = WithRequest $ \req ->

641 route Proxy subserver = WithRequest $ \req ->

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

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

628

643

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

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

630

645

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

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

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

633

648

634 route Proxy subserver = WithRequest $ \req ->

649 route Proxy subserver = WithRequest $ \req ->

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

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

636

651

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

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

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

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

639

654

640 route Proxy subserver = WithRequest $ \req ->

655 route Proxy subserver = WithRequest $ \req ->

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

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

642

657

643pathIsEmpty :: Request -> Bool

658pathIsEmpty :: Request -> Bool

644pathIsEmpty = go . pathInfo

659pathIsEmpty = go . pathInfo

servant-server/src/Servant/Server/Internal/Router.hs+16−8

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

6import qualified Data.Map as M

7import Data.Text (Text)

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

9−import Servant.Server.Internal.ServantErr

10import Servant.Server.Internal.PathInfo

9import Servant.Server.Internal.PathInfo

11import Servant.Server.Internal.RoutingApplication

10import Servant.Server.Internal.RoutingApplication

11+import Servant.Server.Internal.ServantErr

13type Router = Router' RoutingApplication

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

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

78 respond (highestPri mResponse1 mResponse2)

79 _ -> respond mResponse1

80− where

80+ where

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

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

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

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

83− then Fail e2

83+ then Fail e2

84− else Fail e1

84+ else Fail e1

85− highestPri (Fail _) y = y

85+ highestPri (Fail _) y = y

86− highestPri x _ = x

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 @@

2{-# LANGUAGE DeriveFunctor #-}

3{-# LANGUAGE OverloadedStrings #-}

4{-# LANGUAGE TypeOperators #-}

5+{-# LANGUAGE GADTs #-}

6+{-# LANGUAGE KindSignatures #-}

7+{-# LANGUAGE StandaloneDeriving #-}

5module Servant.Server.Internal.RoutingApplication where

8module Servant.Server.Internal.RoutingApplication where

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

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

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

18 Response, ResponseReceived,

21 Response, ResponseReceived,

19 requestBody,

22 requestBody,

20 strictRequestBody)

23 strictRequestBody)

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

22import Servant.Server.Internal.ServantErr

24import Servant.Server.Internal.ServantErr

24type RoutingApplication =

26type RoutingApplication =

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

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

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

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

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

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

29data RouteResult a =

31data RouteResult a =

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

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

31− -- should only be 404 or 405.

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

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

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

33− | Route a

35+ | Route !a

34 deriving (Eq, Show, Read, Functor)

36 deriving (Eq, Show, Read, Functor)

36data ReqBodyState = Uncalled

38data ReqBodyState = Uncalled

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

63 ra request{ requestBody = memoReqBody } routingRespond

65 ra request{ requestBody = memoReqBody } routingRespond

64 where

66 where

65 routingRespond :: RouteResult Response -> IO ResponseReceived

67 routingRespond :: RouteResult Response -> IO ResponseReceived

66− routingRespond (Fail err) = respond $! responseServantErr err

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

67− routingRespond (FailFatal err) = respond $! responseServantErr err

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

68− routingRespond (Route v) = respond v

70+ routingRespond (Route v) = respond v

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.

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

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

71 -> (RouteResult Response -> IO r)

241 -> (RouteResult Response -> IO r)

72 -> (a -> RouteResult Response)

242 -> (a -> RouteResult Response)

73 -> IO r

243 -> IO r

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

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

75 where

245 where

76 go (Fail e) = return $ Fail e

246 go (Fail e) = return $ Fail e

77 go (FailFatal e) = return $ FailFatal e

247 go (FailFatal e) = return $ FailFatal e

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

80 case e of

250 case e of

81 Left err -> return . Route $ responseServantErr err

251 Left err -> return . Route $ responseServantErr err

82 Right x -> return $! k x

252 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 @@

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

6module Servant.Server.ErrorSpec (spec) where

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

8import Data.Aeson (encode)

9import Data.Aeson (encode)

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

10import qualified Data.ByteString.Char8 as BC

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

11import Data.Proxy

12import Data.Proxy

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

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

13 methodPost, methodPut)

14 methodPost, methodPut)

15+import Safe (readMay)

14import Test.Hspec

16import Test.Hspec

15import Test.Hspec.Wai

17import Test.Hspec.Wai

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

54errorOrderApi = Proxy

56errorOrderApi = Proxy

56errorOrderServer :: Server ErrorOrderApi

58errorOrderServer :: Server ErrorOrderApi

57−errorOrderServer = \_ _ -> return 5

59+errorOrderServer = \_ _ -> throwE err402

59errorOrderSpec :: Spec

61errorOrderSpec :: Spec

60errorOrderSpec = describe "HTTP error order"

62errorOrderSpec = describe "HTTP error order"

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

65 badUrl = "home/nonexistent"

67 badUrl = "home/nonexistent"

66 badBody = "nonsense"

68 badBody = "nonsense"

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

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

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

68 goodMethod = methodPost

71 goodMethod = methodPost

69 goodUrl = "home/2"

72 goodUrl = "home/2"

70 goodBody = encode (5 :: Int)

73 goodBody = encode (5 :: Int)

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

89 request goodMethod goodUrl [goodContentType, badAccept] goodBody

92 request goodMethod goodUrl [goodContentType, badAccept] goodBody

90 `shouldRespondWith` 406

93 `shouldRespondWith` 406

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

96+ request goodMethod goodUrl [goodContentType, goodAccept] goodBody

97+ `shouldRespondWith` 402

98+

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

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

100

94prioErrorsApi :: Proxy PrioErrorsApi

101prioErrorsApi :: Proxy PrioErrorsApi

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

107 `shouldRespondWith` resp

114 `shouldRespondWith` resp

108 where

115 where

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

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

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

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

111

118

112 get' = ("GET", methodGet)

119 get' = ("GET", methodGet)

113 put' = ("PUT", methodPut)

120 put' = ("PUT", methodPut)

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

140-- * Error Retry {{{

147-- * Error Retry {{{

141

148

142type ErrorRetryApi

149type ErrorRetryApi

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

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

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

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

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

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

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

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

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

154

161

155errorRetryServer :: Server ErrorRetryApi

162errorRetryServer :: Server ErrorRetryApi

156errorRetryServer

163errorRetryServer

157− = (\_ -> return 0)

164+ = (\_ -> throwE err402)

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

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

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

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

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

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

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

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

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

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

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

183

190

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−

196-- }}}

191-- }}}

197------------------------------------------------------------------------------

192------------------------------------------------------------------------------

198-- * Error Choice {{{

193-- * Error Choice {{{

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

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

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

234 `shouldRespondWith` 400

229 `shouldRespondWith` 400

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

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

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

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

237 `shouldRespondWith` 406

232 `shouldRespondWith` 406

238

233

239

234

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

242-- * Instances {{{

237-- * Instances {{{

243

238

244instance MimeUnrender PlainText Int where

239instance MimeUnrender PlainText Int where

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

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

246

241

247instance MimeRender PlainText Int where

242instance MimeRender PlainText Int where

248 mimeRender _ = BCL.pack . show

243 mimeRender _ = BCL.pack . show

249-- }}}

244-- }}}

250−--

251−

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

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

1−<<<<<<< HEAD

2{-# LANGUAGE CPP #-}

1{-# LANGUAGE CPP #-}

3{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE DataKinds #-}

4{-# LANGUAGE DeriveGeneric #-}

3{-# LANGUAGE DeriveGeneric #-}

5−=======

6−{-# LANGUAGE DataKinds #-}

7−{-# LANGUAGE DeriveGeneric #-}

8{-# LANGUAGE FlexibleInstances #-}

4{-# LANGUAGE FlexibleInstances #-}

9−>>>>>>> Review fixes

10{-# LANGUAGE OverloadedStrings #-}

5{-# LANGUAGE OverloadedStrings #-}

11{-# LANGUAGE ScopedTypeVariables #-}

6{-# LANGUAGE ScopedTypeVariables #-}

12{-# LANGUAGE TypeOperators #-}

7{-# LANGUAGE TypeOperators #-}

13{-# LANGUAGE TypeSynonymInstances #-}

8{-# LANGUAGE TypeSynonymInstances #-}

14−<<<<<<< HEAD

15{-# LANGUAGE FlexibleInstances #-}

9{-# LANGUAGE FlexibleInstances #-}

16−=======

17−>>>>>>> Review fixes

19module Servant.ServerSpec where

11module Servant.ServerSpec where

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

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

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

56 matchStatus, post, request,

48 matchStatus, post, request,

57 shouldRespondWith, with, (<:>))

49 shouldRespondWith, with, (<:>))

50+<<<<<<< HEAD

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

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

59 Get, Header (..), Headers,

52 Get, Header (..), Headers,

60 HttpVersion, IsSecure (..), JSON,

53 HttpVersion, IsSecure (..), JSON,

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

63 Raw, RemoteHost, ReqBody,

56 Raw, RemoteHost, ReqBody,

64 addHeader)

57 addHeader)

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

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

59+=======

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

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

66import Servant.Server.Internal.Router

62import Servant.Server.Internal.Router

67 (tweakResponse, runRouter,

63 (tweakResponse, runRouter,

68 Router, Router'(LeafRouter))

64 Router, Router'(LeafRouter))

69−import Servant.Server.Internal.RoutingApplication

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

71− toApplication)

74-- * test data types

67-- * test data types

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

279 }

272 }

280

273

281 let params3'' = "?unknown="

274 let params3'' = "?unknown="

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

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

283 rawQueryString = params3'',

276 rawQueryString = params3'',

284 queryString = parseQuery params3'',

277 queryString = parseQuery params3'',

285 pathInfo = ["b"]

278 pathInfo = ["b"]

286 }

279 }

287 liftIO $

280 liftIO $

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

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

289 name = "Alice"

282 name = "Alice"

290 }

283 }

291

284

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

553

546

554 router', router :: Router

547 router', router :: Router

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

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

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

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

557

550

558 twk :: Response -> Response

551 twk :: Response -> Response

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

552 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

57 , AcceptHeader(..)

58 , AllCTRender(..)

59 , AllCTUnrender(..)

60+ , AllMime(..)

60 , AllMimeRender(..)

61 , AllMimeRender(..)

61 , AllMimeUnrender(..)

62 , AllMimeUnrender(..)

62 , FromFormUrlEncoded(..)

63 , FromFormUrlEncoded(..)

63 , ToFormUrlEncoded(..)

64 , ToFormUrlEncoded(..)

64 , IsNonEmpty

65 , IsNonEmpty

65 , eitherDecodeLenient

66 , eitherDecodeLenient

67+ , canHandleAcceptH

66 ) where

68 ) where

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

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

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

81 toStrict)

83 toStrict)

82import qualified Data.ByteString.Lazy as B

84import qualified Data.ByteString.Lazy as B

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

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

86+import Data.Maybe (isJust)

84import Data.Monoid

87import Data.Monoid

85import Data.String.Conversions (cs)

88import Data.String.Conversions (cs)

86import qualified Data.Text as TextS

89import qualified Data.Text as TextS

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

156class Accept ctype => MimeRender ctype a where

159class Accept ctype => MimeRender ctype a where

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

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

158

161

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

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

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

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

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

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

162 -- mimetype).

165 -- mimetype).

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

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

164

167

165−instance ( AllMimeRender ctyps a, IsNonEmpty ctyps

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

166− ) => AllCTRender ctyps a where

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

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

168 where pctyps = Proxy :: Proxy ctyps

170 where pctyps = Proxy :: Proxy ctyps

169 amrs = allMimeRender pctyps val

171 amrs = allMimeRender pctyps val

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

211--------------------------------------------------------------------------

213--------------------------------------------------------------------------

212-- * Utils (Internal)

214-- * Utils (Internal)

213

215

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

214

229

215--------------------------------------------------------------------------

230--------------------------------------------------------------------------

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

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

217--------------------------------------------------------------------------

232--------------------------------------------------------------------------

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

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

219 allMimeRender :: Proxy list

234 allMimeRender :: Proxy list

220 -> a -- value to serialize

235 -> a -- value to serialize

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

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

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

239--------------------------------------------------------------------------

254--------------------------------------------------------------------------

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

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

241--------------------------------------------------------------------------

256--------------------------------------------------------------------------

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

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

243 allMimeUnrender :: Proxy list

258 allMimeUnrender :: Proxy list

244 -> ByteString

259 -> ByteString

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

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