git.iko.soy/typeable/servant
on master help sign in
Move more Content-type logic back to servant.
e9f3341Julian K. Arni
src/Servant/Server.hs+1−4
compare with master
unifiedsplit
@@ -10,16 +10,13 @@ module Servant.Server
10 , -- * Handlers for all standard combinators
10 , -- * Handlers for all standard combinators
11 HasServer(..)
11 HasServer(..)
12
12
13− , -- * Building new Content-Types
14− Accept(..)
15− , MimeRender(..)
16 ) where
13 ) where
17
14
18import Data.Proxy (Proxy)
15import Data.Proxy (Proxy)
19import Network.Wai (Application)
16import Network.Wai (Application)
20
17
21import Servant.Server.Internal
18import Servant.Server.Internal
22−import Servant.Server.ContentTypes (Accept(..), MimeRender(..))
19+import Servant.Server.ContentTypes ()
23
20
24
21
25-- * Implementing Servers
22-- * Implementing Servers
src/Servant/Server/ContentTypes.hs+5−155
@@ -11,7 +11,8 @@
11module Servant.Server.ContentTypes where
11module Servant.Server.ContentTypes where
12
12
13import Control.Monad (join)
13import Control.Monad (join)
14+import Control.Arrow (left)
14−import Data.Aeson (ToJSON(..), FromJSON(..), encode, decode)
15+import Data.Aeson (ToJSON(..), FromJSON(..), encode, eitherDecode)
15import Data.ByteString.Lazy (ByteString)
16import Data.ByteString.Lazy (ByteString)
16import qualified Data.ByteString as BS
17import qualified Data.ByteString as BS
17import Data.Proxy (Proxy(..))
18import Data.Proxy (Proxy(..))
@@ -23,86 +24,7 @@ import qualified Network.HTTP.Media as M
23
24
24
25
25import Servant.API ( XML, HTML, JSON, JavaScript, CSS, PlainText
26import Servant.API ( XML, HTML, JSON, JavaScript, CSS, PlainText
26− , OctetStream)
27+ , OctetStream, MimeRender(..), MimeUnrender(..) )
27−
28−-- * Accept class
29−
30−-- | Instances of 'Accept' represent mimetypes. They are used for matching
31−-- against the @Accept@ HTTP header of the request, and for setting the
32−-- @Content-Type@ header of the response
33−--
34−-- Example:
35−--
36−-- > instance Accept HTML where
37−-- > contentType _ = "text" // "html"
38−--
39−class Accept ctype where
40− contentType :: Proxy ctype -> M.MediaType
41−
42−-- | @text/html;charset=utf-8@
43−instance Accept HTML where
44− contentType _ = "text" M.// "html" M./: ("charset", "utf-8")
45−
46−-- | @application/json;charset=utf-8@
47−instance Accept JSON where
48− contentType _ = "application" M.// "json" M./: ("charset", "utf-8")
49−
50−-- | @application/xml;charset=utf-8@
51−instance Accept XML where
52− contentType _ = "application" M.// "xml" M./: ("charset", "utf-8")
53−
54−-- | @application/javascript;charset=utf-8@
55−instance Accept JavaScript where
56− contentType _ = "application" M.// "javascript" M./: ("charset", "utf-8")
57−
58−-- | @text/css;charset=utf-8@
59−instance Accept CSS where
60− contentType _ = "text" M.// "css" M./: ("charset", "utf-8")
61−
62−-- | @text/plain;charset=utf-8@
63−instance Accept PlainText where
64− contentType _ = "text" M.// "plain" M./: ("charset", "utf-8")
65−
66−-- | @application/octet-stream@
67−instance Accept OctetStream where
68− contentType _ = "application" M.// "octet-stream"
69−
70−newtype AcceptHeader = AcceptHeader BS.ByteString
71− deriving (Eq, Show)
72−
73−-- * Render (serializing)
74−
75−-- | Instantiate this class to register a way of serializing a type based
76−-- on the @Accept@ header.
77−--
78−-- Example:
79−--
80−-- > data MyContentType
81−-- >
82−-- > instance Accept MyContentType where
83−-- > contentType _ = "example" // "prs.me.mine" /: ("charset", "utf-8")
84−-- >
85−-- > instance Show a => MimeRender MyContentType where
86−-- > toByteString _ val = pack ("This is MINE! " ++ show val)
87−-- >
88−-- > type MyAPI = "path" :> Get '[MyContentType] Int
89−class Accept ctype => MimeRender ctype a where
90− toByteString :: Proxy ctype -> a -> ByteString
91−
92−class AllCTRender list a where
93− -- If the Accept header can be matched, returns (Just) a tuple of the
94− -- Content-Type and response (serialization of @a@ into the appropriate
95− -- mimetype).
96− handleAcceptH :: Proxy list -> AcceptHeader -> a -> Maybe (ByteString, ByteString)
97−
98−instance ( AllMimeRender ctyps a, IsNonEmpty ctyps
99− ) => AllCTRender ctyps a where
100− handleAcceptH _ (AcceptHeader accept) val = M.mapAcceptMedia lkup accept
101− where pctyps = Proxy :: Proxy ctyps
102− amrs = amr pctyps val
103− lkup = zip (map fst amrs) $ map (\(a,b) -> (cs $ show a, b)) amrs
104−
105−
106
28
107
29
108--------------------------------------------------------------------------
30--------------------------------------------------------------------------
@@ -116,86 +38,14 @@ instance ToJSON a => MimeRender JSON a where
116instance MimeRender PlainText Text.Text where
38instance MimeRender PlainText Text.Text where
117 toByteString _ = Text.encodeUtf8
39 toByteString _ = Text.encodeUtf8
118
40
119−--------------------------------------------------------------------------
120−-- * Unrender
121−class Accept ctype => MimeUnrender ctype a where
122− fromByteString :: Proxy ctype -> ByteString -> Maybe a
123−
124−class AllCTUnrender list a where
125− handleCTypeH :: Proxy list
126− -> ByteString -- Content-Type header
127− -> ByteString -- Request body
128− -> Maybe a
129−
130−instance ( AllMimeUnrender ctyps a, IsNonEmpty ctyps
131− ) => AllCTUnrender ctyps a where
132− handleCTypeH _ ctypeH body = join $ M.mapContentMedia lkup (cs ctypeH)
133− where lkup = amu (Proxy :: Proxy ctyps) body
134−
135−--------------------------------------------------------------------------
136−-- * Utils (Internal)
137−
138−
139−--------------------------------------------------------------------------
140−-- Check that all elements of list are instances of MimeRender
141−--------------------------------------------------------------------------
142−class AllMimeRender ls a where
143− amr :: Proxy ls
144− -> a -- value to serialize
145− -> [(M.MediaType, ByteString)] -- content-types/response pairs
146−
147−instance ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where
148− amr _ a = [(contentType pctyp, toByteString pctyp a)]
149− where pctyp = Proxy :: Proxy ctyp
150−
151−instance ( MimeRender ctyp a
152− , MimeRender ctyp' a -- at least two elems to avoid overlap
153− , AllMimeRender ctyps a
154− ) => AllMimeRender (ctyp ': ctyp' ': ctyps) a where
155− amr _ a = (contentType pctyp, toByteString pctyp a)
156− :(contentType pctyp', toByteString pctyp' a)
157− :(amr pctyps a)
158− where pctyp = Proxy :: Proxy ctyp
159− pctyps = Proxy :: Proxy ctyps
160− pctyp' = Proxy :: Proxy ctyp'
161−
162−
163−instance AllMimeRender '[] a where
164− amr _ _ = []
165−
166−--------------------------------------------------------------------------
167−-- Check that all elements of list are instances of MimeUnrender
168−--------------------------------------------------------------------------
169−class AllMimeUnrender ls a where
170− amu :: Proxy ls -> ByteString -> [(M.MediaType, Maybe a)]
171−
172−instance ( MimeUnrender ctyp a ) => AllMimeUnrender '[ctyp] a where
173− amu _ val = [(contentType pctyp, fromByteString pctyp val)]
174− where pctyp = Proxy :: Proxy ctyp
175−
176−instance ( MimeUnrender ctyp a
177− , MimeUnrender ctyp' a
178− , AllMimeUnrender ctyps a
179− ) => AllMimeUnrender (ctyp ': ctyp' ': ctyps) a where
180− amu _ val = (contentType pctyp, fromByteString pctyp val)
181− :(contentType pctyp', fromByteString pctyp' val)
182− :(amu pctyps val)
183− where pctyp = Proxy :: Proxy ctyp
184− pctyps = Proxy :: Proxy ctyps
185− pctyp' = Proxy :: Proxy ctyp'
186−
187−type family IsNonEmpty (ls::[*]) :: Constraint where
188− IsNonEmpty '[] = 'False ~ 'True
189− IsNonEmpty x = ()
190−
191--------------------------------------------------------------------------
41--------------------------------------------------------------------------
192-- * MimeUnrender Instances
42-- * MimeUnrender Instances
193
43
194-- | @decode@
44-- | @decode@
195instance FromJSON a => MimeUnrender JSON a where
45instance FromJSON a => MimeUnrender JSON a where
196− fromByteString _ = decode
46+ fromByteString _ = eitherDecode
197
47
198-- | @Text.decodeUtf8'@
48-- | @Text.decodeUtf8'@
199instance MimeUnrender PlainText Text.Text where
49instance MimeUnrender PlainText Text.Text where
200− fromByteString _ = either (const Nothing) Just . Text.decodeUtf8'
50+ fromByteString _ = left show . Text.decodeUtf8'
201
51
src/Servant/Server/Internal.hs+29−27
@@ -9,7 +9,7 @@ module Servant.Server.Internal where
9
9
10import Control.Applicative ((<$>))
10import Control.Applicative ((<$>))
11import Control.Monad.Trans.Either (EitherT, runEitherT)
11import Control.Monad.Trans.Either (EitherT, runEitherT)
12−import Data.Aeson (ToJSON, FromJSON, encode, eitherDecode')
12+import Data.Aeson (ToJSON)
13import qualified Data.ByteString as B
13import qualified Data.ByteString as B
14import qualified Data.ByteString.Lazy as BL
14import qualified Data.ByteString.Lazy as BL
15import Data.IORef (newIORef, readIORef, writeIORef)
15import Data.IORef (newIORef, readIORef, writeIORef)
@@ -29,10 +29,10 @@ import Network.Wai ( Response, Request, ResponseReceived, Application
29 , lazyRequestBody, requestHeaders, requestMethod,
29 , lazyRequestBody, requestHeaders, requestMethod,
30 rawQueryString, responseLBS)
30 rawQueryString, responseLBS)
31import Servant.API ( QueryParams, QueryParam, QueryFlag, ReqBody, Header
31import Servant.API ( QueryParams, QueryParam, QueryFlag, ReqBody, Header
32− , MatrixParams, MatrixParam, MatrixFlag,
32+ , MatrixParams, MatrixParam, MatrixFlag
33 , Capture, Get, Delete, Put, Post, Patch, Raw, (:>), (:<|>)(..))
33 , Capture, Get, Delete, Put, Post, Patch, Raw, (:>), (:<|>)(..))
34−import Servant.Server.ContentTypes ( AllCTRender(..), AcceptHeader(..)
34+import Servant.API.ContentTypes ( AllCTRender(..), AcceptHeader(..)
35− , AllCTUnrender(..) )
35+ , AllCTUnrender(..),)
36import Servant.Common.Text (FromText, fromText)
36import Servant.Common.Text (FromText, fromText)
37
37
38
38
@@ -72,39 +72,33 @@ toApplication ra request respond = do
72 respond $ responseLBS methodNotAllowed405 [] "method not allowed"
72 respond $ responseLBS methodNotAllowed405 [] "method not allowed"
73 routingRespond (Left (InvalidBody err)) =
73 routingRespond (Left (InvalidBody err)) =
74 respond $ responseLBS badRequest400 [] $ fromString $ "Invalid JSON in request body: " ++ err
74 respond $ responseLBS badRequest400 [] $ fromString $ "Invalid JSON in request body: " ++ err
75+ routingRespond (Left UnsupportedMediaType) =
76+ respond $ responseLBS unsupportedMediaType415 [] "unsupported media type"
75 routingRespond (Left (HttpError status body)) =
77 routingRespond (Left (HttpError status body)) =
76 respond $ responseLBS status [] $ fromMaybe (BL.fromStrict $ statusMessage status) body
78 respond $ responseLBS status [] $ fromMaybe (BL.fromStrict $ statusMessage status) body
77 routingRespond (Right response) =
79 routingRespond (Right response) =
78 respond response
80 respond response
79
81
82+-- Note that the ordering of the constructors has great significance! It
83+-- determines the Ord instance and, consequently, the monoid instance.
80-- * Route mismatch
84-- * Route mismatch
81data RouteMismatch =
85data RouteMismatch =
82 NotFound -- ^ the usual "not found" error
86 NotFound -- ^ the usual "not found" error
83 | WrongMethod -- ^ a more informative "you just got the HTTP method wrong" error
87 | WrongMethod -- ^ a more informative "you just got the HTTP method wrong" error
88+ | UnsupportedMediaType -- ^ request body has unsupported media type
84 | InvalidBody String -- ^ an even more informative "your json request body wasn't valid" error
89 | InvalidBody String -- ^ an even more informative "your json request body wasn't valid" error
85 | HttpError Status (Maybe BL.ByteString) -- ^ an even even more informative arbitrary HTTP response code error.
90 | HttpError Status (Maybe BL.ByteString) -- ^ an even even more informative arbitrary HTTP response code error.
86− deriving (Eq, Show)
91+ deriving (Eq, Ord, Show)
87
92
88−-- |
89−-- @
90−-- > mempty = NotFound
91−-- >
92−-- > _ `mappend` HttpError s b = HttpError s b
93−-- > HttpError s b `mappend` _ = HttpError s b
94−-- > NotFound `mappend` x = x
95−-- > WrongMethod `mappend` InvalidBody s = InvalidBody s
96−-- > WrongMethod `mappend` _ = WrongMethod
97−-- > InvalidBody s `mappend` _ = InvalidBody s
98−-- @
99instance Monoid RouteMismatch where
93instance Monoid RouteMismatch where
100 mempty = NotFound
94 mempty = NotFound
95+ -- The following isn't great, since it picks @InvalidBody@ based on
96+ -- alphabetical ordering, but any choice would be arbitrary.
97+ --
98+ -- "As one judge said to the other, 'Be just and if you can't be just, be
99+ -- arbitrary'" -- William Burroughs
100+ mappend = max
101
101
102− _ `mappend` HttpError s b = HttpError s b
103− HttpError s b `mappend` _ = HttpError s b
104− NotFound `mappend` x = x
105− WrongMethod `mappend` InvalidBody s = InvalidBody s
106− WrongMethod `mappend` _ = WrongMethod
107− InvalidBody s `mappend` _ = InvalidBody s
108
102
109-- | A wrapper around @'Either' 'RouteMismatch' a@.
103-- | A wrapper around @'Either' 'RouteMismatch' a@.
110newtype RouteResult a =
104newtype RouteResult a =
@@ -401,15 +395,22 @@ instance ( AllCTRender ctypes a
401-- If successfully returning a value, we just require that its type has
395-- If successfully returning a value, we just require that its type has
402-- a 'ToJSON' instance and servant takes care of encoding it for you,
396-- a 'ToJSON' instance and servant takes care of encoding it for you,
403-- yielding status code 201 along the way.
397-- yielding status code 201 along the way.
398+instance ( AllCTRender ctypes a
399+ , Typeable a
404−instance (Typeable a, ToJSON a) => HasServer (Patch a) where
400+ , ToJSON a) => HasServer (Patch ctypes a) where
405− type Server (Patch a) = EitherT (Int, String) IO a
401+ type Server (Patch ctypes a) = EitherT (Int, String) IO a
406
402
407 route Proxy action request respond
403 route Proxy action request respond
408 | pathIsEmpty request && requestMethod request == methodPost = do
404 | pathIsEmpty request && requestMethod request == methodPost = do
409 e <- runEitherT action
405 e <- runEitherT action
410 respond . succeedWith $ case e of
406 respond . succeedWith $ case e of
411 Right out -> case cast out of
407 Right out -> case cast out of
408+ Nothing -> do
409+ let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
410+ case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) out of
411+ Nothing -> responseLBS (mkStatus 406 "") [] ""
412− Nothing -> responseLBS status200 [("Content-Type", "application/json")] (encode out)
412+ Just (contentT, body) -> responseLBS status200 [ ("Content-Type"
413+ , cs contentT)] body
413 Just () -> responseLBS status204 [] ""
414 Just () -> responseLBS status204 [] ""
414 Left (status, message) ->
415 Left (status, message) ->
415 responseLBS (mkStatus status (cs message)) [] (cs message)
416 responseLBS (mkStatus status (cs message)) [] (cs message)
@@ -695,8 +696,9 @@ instance ( AllCTUnrender list a, HasServer sublayout
695 mrqbody <- handleCTypeH (Proxy :: Proxy list) (cs contentTypeH)
696 mrqbody <- handleCTypeH (Proxy :: Proxy list) (cs contentTypeH)
696 <$> lazyRequestBody request
697 <$> lazyRequestBody request
697 case mrqbody of
698 case mrqbody of
699+ Nothing -> respond . failWith $ UnsupportedMediaType
698− Left e -> respond . failWith $ InvalidBody e
700+ Just (Left e) -> respond . failWith $ InvalidBody e
699− Right v -> route (Proxy :: Proxy sublayout) (subserver v) request respond
701+ Just (Right v) -> route (Proxy :: Proxy sublayout) (subserver v) request respond
700
702
701-- | Make sure the incoming request starts with @"/path"@, strip it and
703-- | Make sure the incoming request starts with @"/path"@, strip it and
702-- pass the rest of the request path to @sublayout@.
704-- pass the rest of the request path to @sublayout@.
test/Servant/Server/ContentTypesSpec.hs+2−1
@@ -24,8 +24,9 @@ import Test.Hspec
24import Test.QuickCheck
24import Test.QuickCheck
25
25
26import Servant.API
26import Servant.API
27+import Servant.API.ContentTypes
27import Servant.Server
28import Servant.Server
28−import Servant.Server.ContentTypes
29+import Servant.Server.ContentTypes ()
29
30
30
31
31spec :: Spec
32spec :: Spec
test/Servant/ServerSpec.hs+9−4
@@ -209,10 +209,10 @@ queryParamSpec = do
209 name = "Alice"
209 name = "Alice"
210 }
210 }
211
211
212−type MatrixParamApi = "a" :> MatrixParam "name" String :> Get Person
212+type MatrixParamApi = "a" :> MatrixParam "name" String :> Get '[JSON] Person
213− :<|> "b" :> MatrixParams "names" String :> "bsub" :> MatrixParams "names" String :> Get Person
213+ :<|> "b" :> MatrixParams "names" String :> "bsub" :> MatrixParams "names" String :> Get '[JSON] Person
214− :<|> "c" :> MatrixFlag "capitalize" :> Get Person
214+ :<|> "c" :> MatrixFlag "capitalize" :> Get '[JSON] Person
215− :<|> "d" :> Capture "foo" Integer :> MatrixParam "name" String :> MatrixFlag "capitalize" :> "dsub" :> Get Person
215+ :<|> "d" :> Capture "foo" Integer :> MatrixParam "name" String :> MatrixFlag "capitalize" :> "dsub" :> Get '[JSON] Person
216
216
217matrixParamApi :: Proxy MatrixParamApi
217matrixParamApi :: Proxy MatrixParamApi
218matrixParamApi = Proxy
218matrixParamApi = Proxy
@@ -323,6 +323,11 @@ postSpec = do
323 it "correctly rejects invalid request bodies with status 400" $ do
323 it "correctly rejects invalid request bodies with status 400" $ do
324 post' "/" "some invalid body" `shouldRespondWith` 400
324 post' "/" "some invalid body" `shouldRespondWith` 400
325
325
326+ it "responds with 415 if the requested media type is unsupported" $ do
327+ let post'' x = Test.Hspec.Wai.request methodPost x [(hContentType
328+ , "application/nonsense")]
329+ post'' "/" "anything at all" `shouldRespondWith` 415
330+
326
331
327type RawApi = "foo" :> Raw
332type RawApi = "foo" :> Raw
328rawApi :: Proxy RawApi
333rawApi :: Proxy RawApi