6a4c967 · servant · git.iko.soy

git.iko.soy/servant

on master help sign in

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

6a4c967Julian Arni11 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+11−10

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

5{-# LANGUAGE ScopedTypeVariables #-}

6{-# LANGUAGE TypeFamilies #-}

7{-# LANGUAGE TypeOperators #-}

8import Data.Aeson

9import Data.Aeson

9import Data.ByteString (ByteString)

10import Data.ByteString (ByteString)

10import Data.Text (Text)

11import Data.Text (Text)

11import GHC.Generics

12import GHC.Generics

12−import Network.HTTP.Types

13import Network.Wai

14import Network.Wai.Handler.Warp

15import Servant

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

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

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

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

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

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

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

33+ where

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

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

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

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

35− Just v -> do

36+ Just v -> do

36− authGranted <- isGoodCookie v

37+ authGranted <- isGoodCookie v

37− if authGranted

38+ if authGranted

38− then a

39+ then return $ Route ()

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

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

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

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

servant-server/CHANGELOG.md+3

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

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

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

7* Remove matrix params.

8+* Remove `RouteMismatch`.

9+* Redefined constructors of `RouteResult`.

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

90.4.1

120.4.1

10-----

13-----

servant-server/servant-server.cabal+2

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

95 Servant.Server.Internal.EnterSpec

96 Servant.ServerSpec

97 Servant.Utils.StaticFilesSpec

98+ Servant.Server.ErrorSpec

98 build-depends:

99 build-depends:

99 base == 4.*

100 base == 4.*

100 , aeson

101 , aeson

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

108 , network >= 2.6

109 , network >= 2.6

109 , QuickCheck

110 , QuickCheck

110 , parsec

111 , parsec

112+ , safe

111 , servant

113 , servant

112 , servant-server

114 , servant-server

113 , string-conversions

115 , 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 (RR (Right server)))))

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

107+ where

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

109+ r = return (Route ())

107

110

108

111

109-- Documentation

112-- Documentation

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

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

1−{-# LANGUAGE CPP #-}

1+{-# LANGUAGE CPP #-}

2−{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE FlexibleContexts #-}

3+{-# LANGUAGE FlexibleContexts #-}

4−{-# LANGUAGE FlexibleInstances #-}

4+{-# LANGUAGE FlexibleInstances #-}

5{-# LANGUAGE GeneralizedNewtypeDeriving #-}

6−{-# LANGUAGE OverloadedStrings #-}

6+{-# LANGUAGE OverloadedStrings #-}

7−{-# LANGUAGE PolyKinds #-}

7+{-# LANGUAGE PolyKinds #-}

8−{-# LANGUAGE ScopedTypeVariables #-}

8+{-# LANGUAGE ScopedTypeVariables #-}

9−{-# LANGUAGE TypeFamilies #-}

9+{-# LANGUAGE TypeFamilies #-}

10−{-# LANGUAGE TypeOperators #-}

10+{-# LANGUAGE TypeOperators #-}

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

12−{-# LANGUAGE OverlappingInstances #-}

12+{-# LANGUAGE OverlappingInstances #-}

13#endif

15module Servant.Server.Internal

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

26import qualified Data.ByteString as B

27import qualified Data.ByteString.Lazy as BL

28import qualified Data.Map as M

29−import Data.Maybe (mapMaybe, fromMaybe)

29+import Data.Maybe (fromMaybe, mapMaybe)

30import Data.String (fromString)

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

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

32import Data.Text (Text)

33import Data.Typeable

34import GHC.TypeLits (KnownSymbol, symbolVal)

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

46 Raw, RemoteHost, ReqBody, Vault)

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

48 AllCTRender (..),

49− AllCTUnrender (..))

49+ AllCTUnrender (..),

50+ AllMime,

51+ canHandleAcceptH)

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

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

51− getHeaders)

53+ getResponse)

53import Servant.Server.Internal.Router

55import Servant.Server.Internal.Router

54import Servant.Server.Internal.RoutingApplication

56import Servant.Server.Internal.RoutingApplication

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

116 DynamicRouter $ \ first ->

118 DynamicRouter $ \ first ->

117− route (Proxy :: Proxy sublayout)

119+ route (Proxy :: Proxy sublayout)

118− (case captured captureProxy first of

120+ (addCapture d $ case captured captureProxy first of

119− Nothing -> return $ failWith NotFound

121+ Nothing -> return $ Fail err404

120− Just v -> feedTo subserver v)

122+ Just v -> return $ Route v

123+ )

124+ where

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

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

122

126

123allowedMethodHead :: Method -> Request -> Bool

127allowedMethodHead :: Method -> Request -> Bool

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

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

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

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

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

132 -> Request -> RouteResult Response

136 -> Request -> RouteResult Response

133processMethodRouter handleA status method headers request = case handleA of

137processMethodRouter handleA status method headers request = case handleA of

134− Nothing -> failWith UnsupportedMediaType

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

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

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

136 where

140 where

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

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

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

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

139

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+

140methodRouter :: (AllCTRender ctypes a)

154methodRouter :: (AllCTRender ctypes a)

141 => Method -> Proxy ctypes -> Status

155 => Method -> Proxy ctypes -> Status

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

156+ -> Delayed (ExceptT ServantErr IO a)

143 -> Router

157 -> Router

144methodRouter method proxy status action = LeafRouter route'

158methodRouter method proxy status action = LeafRouter route'

145 where

159 where

146 route' request respond

160 route' request respond

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

161+ | pathIsEmpty request =

148− runAction action respond $ \ output -> do

149− 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

150− handleA = handleAcceptH proxy (AcceptHeader accH) output

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

151− processMethodRouter handleA status method Nothing request

167+ processMethodRouter handleA status method Nothing request

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

153− respond $ failWith WrongMethod

154− | otherwise = respond $ failWith NotFound

168+ | otherwise = respond $ Fail err404

155

169

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

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

157 => Method -> Proxy ctypes -> Status

171 => Method -> Proxy ctypes -> Status

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

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

159 -> Router

173 -> Router

160methodRouterHeaders method proxy status action = LeafRouter route'

174methodRouterHeaders method proxy status action = LeafRouter route'

161 where

175 where

162 route' request respond

176 route' request respond

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

177+ | pathIsEmpty request =

164− runAction action respond $ \ output -> do

165− 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

166− headers = getHeaders output

182+ let headers = getHeaders output

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

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

168− processMethodRouter handleA status method (Just headers) request

184+ processMethodRouter handleA status method (Just headers) request

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

170− respond $ failWith WrongMethod

171− | otherwise = respond $ failWith NotFound

185+ | otherwise = respond $ Fail err404

172

186

173methodRouterEmpty :: Method

187methodRouterEmpty :: Method

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

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

175 -> Router

189 -> Router

176methodRouterEmpty method action = LeafRouter route'

190methodRouterEmpty method action = LeafRouter route'

177 where

191 where

178 route' request respond

192 route' request respond

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

193+ | pathIsEmpty request = do

180− runAction action respond $ \ () ->

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

181− succeedWith $ responseLBS noContent204 [] ""

195+ Route $! responseLBS noContent204 [] ""

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

183− respond $ failWith WrongMethod

184− | otherwise = respond $ failWith NotFound

196+ | otherwise = respond $ Fail err404

185

197

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

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

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

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

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

301

313

302 route Proxy subserver = WithRequest $ \ request ->

314 route Proxy subserver = WithRequest $ \ request ->

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

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

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

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

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

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

306

318

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

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

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

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

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

474 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

475 -- the right type

487 -- the right type

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

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

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

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

478

490

479-- | 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,

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

508 -- corresponding values

520 -- corresponding values

509 parameters = filter looksLikeParam querytext

521 parameters = filter looksLikeParam querytext

510 values = mapMaybe (convert . snd) parameters

522 values = mapMaybe (convert . snd) parameters

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

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

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

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

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

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

514 convert Nothing = Nothing

526 convert Nothing = Nothing

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

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

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

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

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

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

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

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

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

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

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

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

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

544 | otherwise = False

556 | otherwise = False

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

556 type ServerT Raw m = Application

568 type ServerT Raw m = Application

557

569

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

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

559− r <- rawApplication

571+ r <- runDelayed rawApplication

560 case r of

572 case r of

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

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

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

574+ Fail a -> respond $ Fail a

575+ FailFatal e -> respond $ FailFatal e

563

576

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

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

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

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

@@ -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 $ failWith $ UnsupportedMediaType

617+ Nothing -> return $ FailFatal err415

603− Just (Left e) -> return $ failWith $ InvalidBody 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+23−9

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

1{-# LANGUAGE DeriveFunctor #-}

2−

2+{-# LANGUAGE CPP #-}

3module Servant.Server.Internal.Router where

5import Data.Map (Map)

6import qualified Data.Map as M

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

8import Data.Text (Text)

7import Data.Text (Text)

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

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

10import Servant.Server.Internal.RoutingApplication

9import Servant.Server.Internal.RoutingApplication

10+import Servant.Server.Internal.ServantErr

12type Router = Router' RoutingApplication

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

63 | Just router <- M.lookup first table

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

65 in runRouter router request' respond

66− _ -> respond $ failWith NotFound

66+ _ -> respond $ Fail err404

67runRouter (DynamicRouter fun) request respond =

68 case pathInfo request of

69 first : rest

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

71 in runRouter (fun first) request' respond

72− _ -> respond $ failWith NotFound

72+ _ -> respond $ Fail err404

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

74runRouter (Choice r1 r2) request respond =

75− runRouter r1 request $ \ mResponse1 ->

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

76− if isMismatch mResponse1

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

77− then runRouter r2 request $ \ mResponse2 ->

77+ respond (highestPri mResponse1 mResponse2)

78− respond (mResponse1 <> mResponse2)

78+ _ -> respond mResponse1

79− else respond mResponse1

79+ where

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

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

82+ then Fail e2

83+ else Fail e1

84+ highestPri (Fail _) y = y

85+ highestPri x _ = x

86+

87+

88+-- Priority on HTTP codes.

89+--

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

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

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

93+worseHTTPCode = (<)

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

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

1{-# LANGUAGE CPP #-}

2−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

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)

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

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

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

10#endif

12#endif

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

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

12import qualified Data.ByteString as B

14import qualified Data.ByteString as B

13import qualified Data.ByteString.Lazy as BL

15import qualified Data.ByteString.Lazy as BL

14import Data.IORef (newIORef, readIORef,

16import Data.IORef (newIORef, readIORef,

15 writeIORef)

17 writeIORef)

16−import Data.Maybe (fromMaybe)

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

18−import Data.String (fromString)

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

20− ResponseHeaders)

21import Network.Wai (Application, Request,

18import Network.Wai (Application, Request,

22 Response, ResponseReceived,

19 Response, ResponseReceived,

23− requestBody, responseLBS,

20+ requestBody,

24 strictRequestBody)

21 strictRequestBody)

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

26import Servant.Server.Internal.ServantErr

22import Servant.Server.Internal.ServantErr

28type RoutingApplication =

24type RoutingApplication =

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

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

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

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

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

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

33−newtype RouteResult a =

29+data RouteResult a =

34− RR { routeResult :: Either RouteMismatch a }

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

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

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

36−

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

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

33+ | Route !a

38−--

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

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

41−instance Monoid (RouteResult a) where

42− mempty = RR $ Left mempty

43−

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

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

46− r `mappend` _ = r

47−

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

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

50−data RouteMismatch =

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

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

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

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

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

56− deriving (Eq, Ord, Show)

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

57−

58−instance Monoid RouteMismatch where

59− mempty = NotFound

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

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

62− --

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

64− -- arbitrary'" -- William Burroughs

65− mappend = max

67data ReqBodyState = Uncalled

36data ReqBodyState = Uncalled

68 | Called !B.ByteString

37 | Called !B.ByteString

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

91 writeIORef reqBodyRef $ Called bs

60 writeIORef reqBodyRef $ Called bs

92 return B.empty

61 return B.empty

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

63+ ra request{ requestBody = memoReqBody } routingRespond

95 where

64 where

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

65+ routingRespond :: RouteResult Response -> IO ResponseReceived

97− routingRespond (Left NotFound) =

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

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

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

99− routingRespond (Left WrongMethod) =

68+ routingRespond (Route v) = respond v

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

69+

101− routingRespond (Left (InvalidBody err)) =

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

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

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

103− routingRespond (Left UnsupportedMediaType) =

72+--

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

74+-- and therefore get 404 before 405.

75+--

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

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

78+--

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

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

81+--

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

83+--

84+-- static routes (can cause 404)

85+-- delayed captures (can cause 404)

86+-- methods (can cause 405)

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

88+-- accept header (can cause 406)

89+--

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

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

92+--

93+

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

95+-- delayed checks that can trigger errors.

96+--

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

98+--

99+-- There are two reasons:

100+--

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

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

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

104+-- but rather return this error.

105+--

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

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

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

109+--

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

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

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

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

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

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

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

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

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

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

120+--

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

122+-- codes:

123+--

124+-- @

125+-- 404

126+-- 405 (bad method)

127+-- 401 (unauthorized)

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

128+-- 415 (unsupported media type)

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

129+-- 400 (bad request)

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

130+-- 406 (not acceptable)

107− routingRespond (Right response) =

131+-- @

108− respond response

132+--

109−

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

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

135+--

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

137+-- the actual handler:

138+--

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

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

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

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

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

144+--

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

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

147+-- are comparatively cheap.

148+--

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

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

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

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

153+--

154+data Delayed :: * -> * where

155+ Delayed :: IO (RouteResult a)

156+ -> IO (RouteResult ())

157+ -> IO (RouteResult b)

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

159+ -> Delayed c

160+

161+instance Functor Delayed where

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

163+

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

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

166+ -> IO (RouteResult a)

167+ -> Delayed b

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

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

170+

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

172+addMethodCheck :: Delayed a

173+ -> IO (RouteResult ())

174+ -> Delayed a

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

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

177+

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

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

180+ -> IO (RouteResult a)

181+ -> Delayed b

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

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

184+

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

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

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

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

189+addAcceptCheck :: Delayed a

190+ -> IO (RouteResult ())

191+ -> Delayed a

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

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

194+

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

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

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

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

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

200+

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

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

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

204+--

205+-- We stop on the first error.

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

207+bindRouteResults m f = do

208+ r <- m

209+ case r of

210+ Fail e -> return $ Fail e

211+ FailFatal e -> return $ FailFatal e

212+ Route a -> f a

213+

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

215+-- to 'liftM2'.

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

217+combineRouteResults f m1 m2 =

218+ m1 `bindRouteResults` \ a ->

219+ m2 `bindRouteResults` \ b ->

220+ return (Route (f a b))

221+

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

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

224+-- blocks on to the actual handler.

225+runDelayed :: Delayed a

226+ -> IO (RouteResult a)

227+runDelayed (Delayed captures method body server) =

228+ captures `bindRouteResults` \ c ->

229+ method `bindRouteResults` \ _ ->

230+ body `bindRouteResults` \ b ->

231+ return (server c b)

232+

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

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

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

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

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

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

111 -> (RouteResult Response -> IO r)

238 -> (RouteResult Response -> IO r)

112 -> (a -> RouteResult Response)

239 -> (a -> RouteResult Response)

113 -> IO r

240 -> IO r

114−runAction action respond k = do

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

115− r <- action

116− go r

117 where

242 where

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

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

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

245+ go (Route a) = do

119 e <- runExceptT a

246 e <- runExceptT a

120− respond $ case e of

247+ case e of

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

121− Right x -> k x

249+ Right x -> return $! k x

122− Left err -> succeedWith $ responseServantErr err

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

124−

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

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

127−

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

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

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

131−

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

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

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

135−

136−failWith :: RouteMismatch -> RouteResult a

137−failWith = RR . Left

138−

139−succeedWith :: a -> RouteResult a

140−succeedWith = RR . Right

141−

142−isMismatch :: RouteResult a -> Bool

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

144−isMismatch _ = False

145−

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

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

11 , errReasonPhrase :: String

12 , errBody :: LBS.ByteString

13 , errHeaders :: [HTTP.Header]

14− } deriving (Show, Eq)

14+ } deriving (Show, Eq, Read)

16responseServantErr :: ServantErr -> Response

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

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

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

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE MultiParamTypeClasses #-}

3+{-# LANGUAGE OverloadedStrings #-}

4+{-# LANGUAGE TypeOperators #-}

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

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

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

9+import Data.Aeson (encode)

10+import qualified Data.ByteString.Char8 as BC

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

12+import Data.Proxy

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

14+ methodPost, methodPut)

15+import Safe (readMay)

16+import Test.Hspec

17+import Test.Hspec.Wai

18+

19+import Servant

20+

21+spec :: Spec

22+spec = describe "HTTP Errors" $ do

23+ errorOrderSpec

24+ prioErrorsSpec

25+ errorRetrySpec

26+ errorChoiceSpec

27+

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

29+-- * Error Order {{{

30+

31+type ErrorOrderApi = "home"

32+ :> ReqBody '[JSON] Int

33+ :> Capture "t" Int

34+ :> Post '[JSON] Int

35+

36+

37+errorOrderApi :: Proxy ErrorOrderApi

38+errorOrderApi = Proxy

39+

40+errorOrderServer :: Server ErrorOrderApi

41+errorOrderServer = \_ _ -> throwE err402

42+

43+errorOrderSpec :: Spec

44+errorOrderSpec = describe "HTTP error order"

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

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

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

48+ badMethod = methodGet

49+ badUrl = "home/nonexistent"

50+ badBody = "nonsense"

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

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

53+ goodMethod = methodPost

54+ goodUrl = "home/2"

55+ goodBody = encode (5 :: Int)

56+

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

58+ request badMethod badUrl [badContentType, badAccept] badBody

59+ `shouldRespondWith` 404

60+

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

62+ request badMethod goodUrl [badContentType, badAccept] badBody

63+ `shouldRespondWith` 405

64+

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

66+ request goodMethod goodUrl [badContentType, badAccept] badBody

67+ `shouldRespondWith` 415

68+

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

70+ request goodMethod goodUrl [goodContentType, badAccept] badBody

71+ `shouldRespondWith` 400

72+

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

74+ request goodMethod goodUrl [goodContentType, badAccept] goodBody

75+ `shouldRespondWith` 406

76+

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

78+ request goodMethod goodUrl [goodContentType, goodAccept] goodBody

79+ `shouldRespondWith` 402

80+

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

82+

83+prioErrorsApi :: Proxy PrioErrorsApi

84+prioErrorsApi = Proxy

85+

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

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

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

89+prioErrorsSpec :: Spec

90+prioErrorsSpec = describe "PrioErrors" $ do

91+ let server = return

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

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

94+ it fulldescr $

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

96+ `shouldRespondWith` resp

97+ where

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

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

100+

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

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

103+

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

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

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

107+

108+ check get' "/" txt 404

109+ check get' "/bar" txt 404

110+ check get' "/foo" txt 415

111+ check put' "/" txt 404

112+ check put' "/bar" txt 404

113+ check put' "/foo" txt 405

114+ check get' "/" ijson 404

115+ check get' "/bar" ijson 404

116+ check get' "/foo" ijson 400

117+ check put' "/" ijson 404

118+ check put' "/bar" ijson 404

119+ check put' "/foo" ijson 405

120+ check get' "/" vjson 404

121+ check get' "/bar" vjson 404

122+ check get' "/foo" vjson 200

123+ check put' "/" vjson 404

124+ check put' "/bar" vjson 404

125+ check put' "/foo" vjson 405

126+

127+-- }}}

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

129+-- * Error Retry {{{

130+

131+type ErrorRetryApi

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

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

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

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

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

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

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

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

140+

141+errorRetryApi :: Proxy ErrorRetryApi

142+errorRetryApi = Proxy

143+

144+errorRetryServer :: Server ErrorRetryApi

145+errorRetryServer

146+ = (\_ -> throwE err402)

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

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

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

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

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

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

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

154+

155+errorRetrySpec :: Spec

156+errorRetrySpec = describe "Handler search"

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

158+

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

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

161+ jsonBody = encode (1797 :: Int)

162+

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

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

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

166+

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

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

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

170+

171+-- }}}

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

173+-- * Error Choice {{{

174+

175+type ErrorChoiceApi

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

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

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

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

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

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

182+

183+errorChoiceApi :: Proxy ErrorChoiceApi

184+errorChoiceApi = Proxy

185+

186+errorChoiceServer :: Server ErrorChoiceApi

187+errorChoiceServer = return 0

188+ :<|> return 1

189+ :<|> return 2

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

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

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

193+

194+

195+errorChoiceSpec :: Spec

196+errorChoiceSpec = describe "Multiple handlers return errors"

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

198+

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

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

201+

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

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

204+

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

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

207+ `shouldRespondWith` 415

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

209+ `shouldRespondWith` 400

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

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

212+ `shouldRespondWith` 406

213+

214+

215+-- }}}

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

217+-- * Instances {{{

218+

219+instance MimeUnrender PlainText Int where

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

221+

222+instance MimeRender PlainText Int where

223+ mimeRender _ = BCL.pack . show

224+-- }}}

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

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

1{-# LANGUAGE CPP #-}

2{-# LANGUAGE DataKinds #-}

3{-# LANGUAGE DeriveGeneric #-}

4+{-# LANGUAGE FlexibleInstances #-}

4{-# LANGUAGE OverloadedStrings #-}

5{-# LANGUAGE OverloadedStrings #-}

5{-# LANGUAGE ScopedTypeVariables #-}

6{-# LANGUAGE ScopedTypeVariables #-}

6{-# LANGUAGE TypeOperators #-}

7{-# LANGUAGE TypeOperators #-}

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

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

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

18import Data.ByteString.Conversion ()

19import Data.ByteString.Conversion ()

19import Data.Char (toUpper)

20import Data.Char (toUpper)

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

21import Data.Proxy (Proxy (Proxy))

22import Data.String (fromString)

23import Data.String.Conversions (cs)

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

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

27 methodDelete, methodGet, methodHead,

28 methodPatch, methodPost, methodPut,

29− ok200, parseQuery, status409,

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

30− Status(..))

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

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

32 queryString, rawQueryString,

31 queryString, rawQueryString,

33 responseLBS, responseBuilder)

32 responseLBS, responseBuilder)

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

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

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

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

36 runSession, simpleBody)

35 runSession, simpleBody)

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

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

39− matchStatus, post, request,

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

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

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

42 Get, Header (..), Headers,

37 Get, Header (..), Headers,

43 HttpVersion, IsSecure (..), JSON,

38 HttpVersion, IsSecure (..), JSON,

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

46 Raw, RemoteHost, ReqBody,

41 Raw, RemoteHost, ReqBody,

47 addHeader)

42 addHeader)

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

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

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

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

46+ matchStatus, post, request,

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

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

49import Servant.Server.Internal.Router

50 (tweakResponse, runRouter,

51 Router, Router'(LeafRouter))

52−import Servant.Server.Internal.RoutingApplication

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

54− toApplication)

57-- * test data types

54-- * test data types

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

98 headerSpec

95 headerSpec

99 rawSpec

96 rawSpec

100 unionSpec

97 unionSpec

101− prioErrorsSpec

102− errorsSpec

103 routerSpec

98 routerSpec

104 responseHeadersSpec

99 responseHeadersSpec

105 miscReqCombinatorsSpec

100 miscReqCombinatorsSpec

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

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

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

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

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

160

155

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

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

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

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

163− `shouldRespondWith` 415

158+ `shouldRespondWith` 406

164

159

165

160

166headSpec :: Spec

161headSpec :: Spec

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

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

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

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

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

188

183

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

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

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

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

191− `shouldRespondWith` 415

186+ `shouldRespondWith` 406

192

187

193

188

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

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

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

264 }

259 }

265

260

266 let params3'' = "?unknown="

261 let params3'' = "?unknown="

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

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

268 rawQueryString = params3'',

263 rawQueryString = params3'',

269 queryString = parseQuery params3'',

264 queryString = parseQuery params3'',

270 pathInfo = ["b"]

265 pathInfo = ["b"]

271 }

266 }

272 liftIO $

267 liftIO $

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

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

274 name = "Alice"

269 name = "Alice"

275 }

270 }

276

271

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

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

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

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

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

313

308

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

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

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

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

316 , "application/nonsense")]

311 , "application/nonsense")]

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

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

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

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

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

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

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

355

350

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

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

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

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

358 , "application/nonsense")]

353 , "application/nonsense")]

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

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

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

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

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

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

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

397

392

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

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

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

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

400 , "application/nonsense")]

395 , "application/nonsense")]

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

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

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

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

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

525 `shouldRespondWith` 404

520 `shouldRespondWith` 404

526

521

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

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

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

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

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

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

530− `shouldRespondWith` 415

525+ `shouldRespondWith` 406

531−

526+

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

533−

534−prioErrorsApi :: Proxy PrioErrorsApi

535−prioErrorsApi = Proxy

536−

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

538−--

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

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

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

542−--

543−prioErrorsSpec :: Spec

544−prioErrorsSpec = describe "PrioErrors" $ do

545− let server = return . age

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

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

548− it fulldescr $

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

550− `shouldRespondWith` resp

551− where

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

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

554−

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

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

557−

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

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

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

561−

562− check get' "/" txt 404

563− check get' "/bar" txt 404

564− check get' "/foo" txt 415

565− check put' "/" txt 404

566− check put' "/bar" txt 404

567− check put' "/foo" txt 405

568− check get' "/" ijson 404

569− check get' "/bar" ijson 404

570− check get' "/foo" ijson 400

571− check put' "/" ijson 404

572− check put' "/bar" ijson 404

573− check put' "/foo" ijson 405

574− check get' "/" vjson 404

575− check get' "/bar" vjson 404

576− check get' "/foo" vjson 200

577− check put' "/" vjson 404

578− check put' "/bar" vjson 404

579− check put' "/foo" vjson 405

580−

581−-- | Test server error functionality.

582−errorsSpec :: Spec

583−errorsSpec = do

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

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

586− let wm = WrongMethod

587− let nf = NotFound

588−

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

590− it "HttpError > *" $ do

591− ib <> he `shouldBe` he

592− wm <> he `shouldBe` he

593− nf <> he `shouldBe` he

594−

595− he <> ib `shouldBe` he

596− he <> wm `shouldBe` he

597− he <> nf `shouldBe` he

598−

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

600− he <> ib `shouldBe` he

601− wm <> ib `shouldBe` ib

602− nf <> ib `shouldBe` ib

603−

604− ib <> he `shouldBe` he

605− ib <> wm `shouldBe` ib

606− ib <> nf `shouldBe` ib

607−

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

609− he <> wm `shouldBe` he

610− ib <> wm `shouldBe` ib

611− nf <> wm `shouldBe` wm

612−

613− wm <> he `shouldBe` he

614− wm <> ib `shouldBe` ib

615− wm <> nf `shouldBe` wm

616−

617− it "* > NotFound" $ do

618− he <> nf `shouldBe` he

619− ib <> nf `shouldBe` ib

620− wm <> nf `shouldBe` wm

621−

622− nf <> he `shouldBe` he

623− nf <> ib `shouldBe` ib

624− nf <> wm `shouldBe` wm

625

527

626routerSpec :: Spec

528routerSpec :: Spec

627routerSpec = do

529routerSpec = do

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

631

533

632 router', router :: Router

534 router', router :: Router

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

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

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

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

635

537

636 twk :: Response -> Response

538 twk :: Response -> Response

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

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

servant/CHANGELOG.md+1

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

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

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

8* Remove matrix params.

9+* Add PlainText String MimeRender and MimeUnrender instances.

100.4.2

110.4.2

11-----

12-----

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

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

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

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

81 toStrict)

83 toStrict)

82import qualified Data.ByteString.Lazy as B

84import qualified Data.ByteString.Lazy as B

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

86+import Data.Maybe (isJust)

83import Data.Monoid

87import Data.Monoid

84import Data.String.Conversions (cs)

88import Data.String.Conversions (cs)

85import qualified Data.Text as TextS

89import qualified Data.Text as TextS

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

155class Accept ctype => MimeRender ctype a where

159class Accept ctype => MimeRender ctype a where

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

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

157

161

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

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

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

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

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

161 -- mimetype).

165 -- mimetype).

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

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

163

167

164−instance ( AllMimeRender ctyps a, IsNonEmpty ctyps

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

165− ) => AllCTRender ctyps a where

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

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

167 where pctyps = Proxy :: Proxy ctyps

170 where pctyps = Proxy :: Proxy ctyps

168 amrs = allMimeRender pctyps val

171 amrs = allMimeRender pctyps val

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

210--------------------------------------------------------------------------

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

211-- * Utils (Internal)

214-- * Utils (Internal)

212

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

213

229

214--------------------------------------------------------------------------

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

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

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

216--------------------------------------------------------------------------

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

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

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

218 allMimeRender :: Proxy list

234 allMimeRender :: Proxy list

219 -> a -- value to serialize

235 -> a -- value to serialize

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

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

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

238--------------------------------------------------------------------------

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

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

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

240--------------------------------------------------------------------------

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

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

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

242 allMimeUnrender :: Proxy list

258 allMimeUnrender :: Proxy list

243 -> ByteString

259 -> ByteString

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

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

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

279instance MimeRender PlainText TextS.Text where

295instance MimeRender PlainText TextS.Text where

280 mimeRender _ = fromStrict . TextS.encodeUtf8

296 mimeRender _ = fromStrict . TextS.encodeUtf8

281

297

298+-- | @BC.pack@

299+instance MimeRender PlainText String where

300+ mimeRender _ = BC.pack

301+

282-- | @id@

302-- | @id@

283instance MimeRender OctetStream ByteString where

303instance MimeRender OctetStream ByteString where

284 mimeRender _ = id

304 mimeRender _ = id

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

328instance MimeUnrender PlainText TextS.Text where

348instance MimeUnrender PlainText TextS.Text where

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

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

330

350

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

352+instance MimeUnrender PlainText String where

353+ mimeUnrender _ = Right . BC.unpack

354+

331-- | @Right . id@

355-- | @Right . id@

332instance MimeUnrender OctetStream ByteString where

356instance MimeUnrender OctetStream ByteString where

333 mimeUnrender _ = Right . id

357 mimeUnrender _ = Right . id

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

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

3{-# LANGUAGE DeriveGeneric #-}

4{-# LANGUAGE MultiParamTypeClasses #-}

5{-# LANGUAGE OverloadedStrings #-}

6+{-# LANGUAGE PolyKinds #-}

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

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

7module Servant.API.ContentTypesSpec where

8module Servant.API.ContentTypesSpec where

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

34spec :: Spec

35spec :: Spec

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

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

38+ describe "handleAcceptH" $ do

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

40+

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

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

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

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

45+ without wisdom `shouldBe` with wisdom

46+

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

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

49+ s = "cheese" :: String

50+ badCharset s `shouldBe` Nothing

51+

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

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

38 let p = Proxy :: Proxy JSON

53 let p = Proxy :: Proxy JSON