git.iko.soy/servant
on master help sign in
Add Accept header handling.
commit380acb3efa5e0162fd87519abae893fc67da3244 authorJulian K. Arni <jkarni@gmail.com> dateMon 12 Jan 2015, 15:08 (12 years ago) parentc1377e0
7 files changed+308−27
compare with master
unifiedsplit
default.nix+15 servant-server.cabal+2 src/Servant/Server/ContentTypes.hs+114 src/Servant/Server/Internal.hs+36−17 test/Servant/Server/ContentTypesSpec.hs+129 test/Servant/ServerSpec.hs+10−9 test/Servant/Utils/StaticFilesSpec.hs+2−1
default.nixnew file+15
@@ -0,0 +1,15 @@
1+{ pkgs ? import <nixpkgs> { config.allowUnfree = true; }
2+, src ? builtins.filterSource (path: type:
3+ type != "unknown" &&
4+ baseNameOf path != ".git" &&
5+ baseNameOf path != "result" &&
6+ baseNameOf path != "dist") ./.
7+, servant ? import ../servant {}
8+}:
9+pkgs.haskellPackages.buildLocalCabalWithArgs {
10+ name = "servant-server";
11+ inherit src;
12+ args = {
13+ inherit servant;
14+ };
15+}
servant-server.cabal+2
@@ -31,6 +31,7 @@ library
3131 exposed-modules:
3232 Servant
3333 Servant.Server
34+ Servant.Server.ContentTypes
3435 Servant.Server.Internal
3536 Servant.Utils.StaticFiles
3637 build-depends:
@@ -41,6 +42,7 @@ library
4142 , either >= 4.3
4243 , http-types
4344 , network-uri >= 2.6
45+ , http-media == 0.4.*
4446 , safe
4547 , servant >= 0.2.2
4648 , split
src/Servant/Server/ContentTypes.hsnew file+114
@@ -0,0 +1,114 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE FlexibleInstances #-}
3+{-# LANGUAGE MultiParamTypeClasses #-}
4+{-# LANGUAGE OverloadedStrings #-}
5+{-# LANGUAGE PolyKinds #-}
6+{-# LANGUAGE ScopedTypeVariables #-}
7+{-# LANGUAGE TypeFamilies #-}
8+{-# LANGUAGE TypeOperators #-}
9+{-# LANGUAGE UndecidableInstances #-}
10+module Servant.Server.ContentTypes where
11+
12+import Data.Aeson (ToJSON(..), encode)
13+import Data.ByteString.Lazy (ByteString)
14+import qualified Data.ByteString as BS
15+import Data.Proxy (Proxy(..))
16+import Data.String.Conversions (cs)
17+import qualified Network.HTTP.Media as M
18+
19+
20+import Servant.API (XML, HTML, JSON, JavaScript, CSS, PlainText)
21+
22+-- | Instances of 'Accept' represent mimetypes. They are used for matching
23+-- against the @Accept@ HTTP header of the request, and for setting the
24+-- @Content-Type@ header of the response
25+--
26+-- Example:
27+--
28+-- instance Accept HTML where
29+-- contentType _ = "text" // "html"
30+--
31+class Accept ctype where
32+ contentType :: Proxy ctype -> M.MediaType
33+
34+instance Accept HTML where
35+ contentType _ = "text" M.// "html"
36+
37+instance Accept JSON where
38+ contentType _ = "application" M.// "json"
39+
40+instance Accept XML where
41+ contentType _ = "application" M.// "xml"
42+
43+instance Accept JavaScript where
44+ contentType _ = "application" M.// "javascript"
45+
46+instance Accept CSS where
47+ contentType _ = "text" M.// "css"
48+
49+instance Accept PlainText where
50+ contentType _ = "text" M.// "plain"
51+
52+newtype AcceptHeader = AcceptHeader BS.ByteString
53+ deriving (Eq, Show)
54+
55+-- | Instantiate this class to register a way of serializing a type based
56+-- on the @Accept@ header.
57+class Accept ctype => MimeRender ctype a where
58+ toByteString :: Proxy ctype -> a -> ByteString
59+
60+class AllCTRender list a where
61+ -- If the Accept header can be matched, returns (Just) a tuple of the
62+ -- Content-Type and response (serialization of @a@ into the appropriate
63+ -- mimetype).
64+ handleAcceptH :: Proxy list -> AcceptHeader -> a -> Maybe (ByteString, ByteString)
65+
66+instance ( AllMimeRender ctyps a, IsEmpty ctyps ~ 'False
67+ ) => AllCTRender ctyps a where
68+ handleAcceptH _ (AcceptHeader accept) val = M.mapAcceptMedia lkup accept
69+ where pctyps = Proxy :: Proxy ctyps
70+ amrs = amr pctyps val
71+ lkup = zip (map fst amrs) $ map (\(a,b) -> (cs $ show a, b)) amrs
72+
73+
74+--------------------------------------------------------------------------
75+-- Check that all elements of list are instances of MimeRender
76+--------------------------------------------------------------------------
77+class AllMimeRender ls a where
78+ amr :: Proxy ls -> a -> [(M.MediaType, ByteString)] -- list of content-types/response pairs
79+
80+instance ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where
81+ amr _ a = [(contentType pctyp, toByteString pctyp a)]
82+ where pctyp = Proxy :: Proxy ctyp
83+
84+instance ( MimeRender ctyp a
85+ , MimeRender ctyp' a
86+ , AllMimeRender ctyps a
87+ ) => AllMimeRender (ctyp ': ctyp' ': ctyps) a where
88+ amr _ a = (contentType pctyp, toByteString pctyp a)
89+ :(contentType pctyp', toByteString pctyp' a)
90+ :(amr pctyps a)
91+ where pctyp = Proxy :: Proxy ctyp
92+ pctyps = Proxy :: Proxy ctyps
93+ pctyp' = Proxy :: Proxy ctyp'
94+
95+
96+instance AllMimeRender '[] a where
97+ amr _ _ = []
98+
99+type family IsEmpty (ls::[*]) where
100+ IsEmpty '[] = 'True
101+ IsEmpty x = 'False
102+
103+--------------------------------------------------------------------------
104+-- MimeRender Instances
105+--------------------------------------------------------------------------
106+
107+instance ToJSON a => MimeRender JSON a where
108+ toByteString _ = encode
109+
110+instance Show a => MimeRender PlainText a where
111+ toByteString _ = encode . show
112+
113+instance MimeRender PlainText String where
114+ toByteString _ = encode
src/Servant/Server/Internal.hs+36−17
@@ -24,10 +24,14 @@ import qualified Data.Text as T
2424import Data.Typeable
2525import GHC.TypeLits (KnownSymbol, symbolVal)
2626import Network.HTTP.Types hiding (Header)
27−import Network.Wai (Response, Request, ResponseReceived, Application, pathInfo, requestBody,
28− strictRequestBody, lazyRequestBody, requestHeaders, requestMethod,
27+import Network.Wai ( Response, Request, ResponseReceived, Application
28+ , pathInfo, requestBody, strictRequestBody
29+ , lazyRequestBody, requestHeaders, requestMethod,
2930 rawQueryString, responseLBS)
30−import Servant.API (QueryParams, QueryParam, QueryFlag, MatrixParams, MatrixParam, MatrixFlag, ReqBody, Header, Capture, Get, Delete, Put, Post, Patch, Raw, (:>), (:<|>)(..))
31+import Servant.API ( QueryParams, QueryParam, QueryFlag, ReqBody, Header
32+ , MatrixParams, MatrixParam, MatrixFlag,
33+ , Capture, Get, Delete, Put, Post, Patch, Raw, (:>), (:<|>)(..))
34+import Servant.Server.ContentTypes (AllCTRender(..), AcceptHeader(..))
3135import Servant.Common.Text (FromText, fromText)
3236
3337data ReqBodyState = Uncalled
@@ -225,7 +229,7 @@ instance (KnownSymbol capture, FromText a, HasServer sublayout)
225229 _ -> respond $ failWith NotFound
226230
227231 where captureProxy = Proxy :: Proxy (Capture capture a)
228−
232+
229233
230234-- | If you have a 'Delete' endpoint in your API,
231235-- the handler for this endpoint is meant to delete
@@ -264,14 +268,19 @@ instance HasServer Delete where
264268-- If successfully returning a value, we just require that its type has
265269-- a 'ToJSON' instance and servant takes care of encoding it for you,
266270-- yielding status code 200 along the way.
267−instance ToJSON result => HasServer (Get result) where
268− type Server (Get result) = EitherT (Int, String) IO result
271+instance ( AllCTRender ctypes a, ToJSON a
272+ ) => HasServer (Get ctypes a) where
273+ type Server (Get ctypes a) = EitherT (Int, String) IO a
269274 route Proxy action request respond
270275 | pathIsEmpty request && requestMethod request == methodGet = do
271276 e <- runEitherT action
272277 respond . succeedWith $ case e of
273− Right output ->
274− responseLBS ok200 [("Content-Type", "application/json")] (encode output)
278+ Right output -> do
279+ let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
280+ case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
281+ Nothing -> responseLBS (mkStatus 406 "") [] ""
282+ Just (contentT, body) -> responseLBS ok200 [ ("Content-Type"
283+ , cs contentT)] body
275284 Left (status, message) ->
276285 responseLBS (mkStatus status (cs message)) [] (cs message)
277286 | pathIsEmpty request && requestMethod request /= methodGet =
@@ -321,15 +330,20 @@ instance (KnownSymbol sym, FromText a, HasServer sublayout)
321330-- If successfully returning a value, we just require that its type has
322331-- a 'ToJSON' instance and servant takes care of encoding it for you,
323332-- yielding status code 201 along the way.
324−instance ToJSON a => HasServer (Post a) where
325− type Server (Post a) = EitherT (Int, String) IO a
333+instance ( AllCTRender ctypes a, ToJSON a
334+ )=> HasServer (Post ctypes a) where
335+ type Server (Post ctypes a) = EitherT (Int, String) IO a
326336
327337 route Proxy action request respond
328338 | pathIsEmpty request && requestMethod request == methodPost = do
329339 e <- runEitherT action
330340 respond . succeedWith $ case e of
331− Right out ->
332− responseLBS status201 [("Content-Type", "application/json")] (encode out)
341+ Right output -> do
342+ let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
343+ case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
344+ Nothing -> responseLBS (mkStatus 406 "") [] ""
345+ Just (contentT, body) -> responseLBS status201 [ ("Content-Type"
346+ , cs contentT)] body
333347 Left (status, message) ->
334348 responseLBS (mkStatus status (cs message)) [] (cs message)
335349 | pathIsEmpty request && requestMethod request /= methodPost =
@@ -347,15 +361,20 @@ instance ToJSON a => HasServer (Post a) where
347361-- If successfully returning a value, we just require that its type has
348362-- a 'ToJSON' instance and servant takes care of encoding it for you,
349363-- yielding status code 200 along the way.
350−instance ToJSON a => HasServer (Put a) where
351− type Server (Put a) = EitherT (Int, String) IO a
364+instance ( AllCTRender ctypes a, ToJSON a
365+ ) => HasServer (Put ctypes a) where
366+ type Server (Put ctypes a) = EitherT (Int, String) IO a
352367
353368 route Proxy action request respond
354369 | pathIsEmpty request && requestMethod request == methodPut = do
355370 e <- runEitherT action
356371 respond . succeedWith $ case e of
357− Right out ->
358− responseLBS ok200 [("Content-Type", "application/json")] (encode out)
372+ Right output -> do
373+ let accH = fromMaybe "*/*" $ lookup hAccept $ requestHeaders request
374+ case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
375+ Nothing -> responseLBS (mkStatus 406 "") [] ""
376+ Just (contentT, body) -> responseLBS status200 [ ("Content-Type"
377+ , cs contentT)] body
359378 Left (status, message) ->
360379 responseLBS (mkStatus status (cs message)) [] (cs message)
361380 | pathIsEmpty request && requestMethod request /= methodPut =
@@ -382,7 +401,7 @@ instance (Typeable a, ToJSON a) => HasServer (Patch a) where
382401 e <- runEitherT action
383402 respond . succeedWith $ case e of
384403 Right out -> case cast out of
385− Nothing -> responseLBS status200 [("Content-Type", "application/json")] (encode out)
404+ Nothing -> responseLBS status200 [("Content-Type", "application/json")] (encode out)
386405 Just () -> responseLBS status204 [] ""
387406 Left (status, message) ->
388407 responseLBS (mkStatus status (cs message)) [] (cs message)
test/Servant/Server/ContentTypesSpec.hsnew file+129
@@ -0,0 +1,129 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE FlexibleInstances #-}
3+{-# LANGUAGE MultiParamTypeClasses #-}
4+{-# LANGUAGE OverloadedStrings #-}
5+{-# LANGUAGE TypeOperators #-}
6+{-# OPTIONS_GHC -fno-warn-orphans #-}
7+module Servant.Server.ContentTypesSpec where
8+
9+import Control.Applicative
10+import Data.Aeson (encode)
11+import Data.ByteString.Char8
12+import Data.Function (on)
13+import Data.Maybe (isJust, fromJust)
14+import Data.List (maximumBy)
15+import Data.Proxy (Proxy(..))
16+import Data.String (IsString(..))
17+import Data.String.Conversions (cs)
18+import Network.HTTP.Types (hAccept)
19+import Network.Wai (pathInfo, requestHeaders)
20+import Network.Wai.Test ( runSession, request, defaultRequest
21+ , assertContentType, assertStatus )
22+import Test.Hspec
23+import Test.QuickCheck
24+
25+import Servant.API
26+import Servant.Server
27+import Servant.Server.ContentTypes
28+
29+
30+spec :: Spec
31+spec = describe "Servant.Server.ContentTypes" $ do
32+ handleAcceptHSpec
33+ contentTypeSpec
34+
35+handleAcceptHSpec :: Spec
36+handleAcceptHSpec = describe "handleAcceptH" $ do
37+
38+ it "should return Just if the 'Accept' header matches" $ do
39+ handleAcceptH (Proxy :: Proxy '[JSON]) "*/*" (3 :: Int)
40+ `shouldSatisfy` isJust
41+ handleAcceptH (Proxy :: Proxy '[XML, JSON]) "application/json" (3 :: Int)
42+ `shouldSatisfy` isJust
43+ handleAcceptH (Proxy :: Proxy '[XML, JSON, HTML]) "text/html" (3 :: Int)
44+ `shouldSatisfy` isJust
45+
46+ it "should return the Content-Type as the first element of the tuple" $ do
47+ handleAcceptH (Proxy :: Proxy '[JSON]) "*/*" (3 :: Int)
48+ `shouldSatisfy` ((== "application/json") . fst . fromJust)
49+ handleAcceptH (Proxy :: Proxy '[XML, JSON]) "application/json" (3 :: Int)
50+ `shouldSatisfy` ((== "application/json") . fst . fromJust)
51+ handleAcceptH (Proxy :: Proxy '[XML, JSON, HTML]) "text/html" (3 :: Int)
52+ `shouldSatisfy` ((== "text/html") . fst . fromJust)
53+
54+ it "should return the appropriately serialized representation" $ do
55+ property $ \x -> handleAcceptH (Proxy :: Proxy '[JSON]) "*/*" (x :: Int)
56+ == Just ("application/json", encode x)
57+
58+ it "respects the Accept spec ordering" $
59+ property $ \a b c i -> fst (fromJust $ val a b c i) == (fst $ highest a b c)
60+ where
61+ highest a b c = maximumBy (compare `on` snd) [ ("text/html", a)
62+ , ("application/json", b)
63+ , ("application/xml", c)
64+ ]
65+ acceptH a b c = addToAccept (Proxy :: Proxy HTML) a $
66+ addToAccept (Proxy :: Proxy JSON) b $
67+ addToAccept (Proxy :: Proxy XML ) c ""
68+ val a b c i = handleAcceptH (Proxy :: Proxy '[HTML, JSON, XML])
69+ (acceptH a b c) (i :: Int)
70+
71+type ContentTypeApi = "foo" :> Get '[JSON] Int
72+ :<|> "bar" :> Get '[JSON, PlainText] Int
73+
74+contentTypeApi :: Proxy ContentTypeApi
75+contentTypeApi = Proxy
76+
77+contentTypeServer :: Server ContentTypeApi
78+contentTypeServer = return 5 :<|> return 3
79+
80+contentTypeSpec :: Spec
81+contentTypeSpec = do
82+ describe "Accept Headers" $ do
83+
84+ it "uses the highest quality possible in the header" $
85+ flip runSession (serve contentTypeApi contentTypeServer) $ do
86+ let acceptH = "text/plain; q=0.9, application/json; q=0.8"
87+ response <- Network.Wai.Test.request defaultRequest{
88+ requestHeaders = [(hAccept, acceptH)] ,
89+ pathInfo = ["bar"]
90+ }
91+ assertContentType "text/plain" response
92+
93+ it "returns the first content-type if the Accept header is missing" $
94+ flip runSession (serve contentTypeApi contentTypeServer) $ do
95+ response <- Network.Wai.Test.request defaultRequest{
96+ pathInfo = ["bar"]
97+ }
98+ assertContentType "application/json" response
99+
100+ it "returns 406 if it can't serve the requested content-type" $
101+ flip runSession (serve contentTypeApi contentTypeServer) $ do
102+ let acceptH = "text/css"
103+ response <- Network.Wai.Test.request defaultRequest{
104+ requestHeaders = [(hAccept, acceptH)] ,
105+ pathInfo = ["bar"]
106+ }
107+ assertStatus 406 response
108+
109+
110+instance Show a => MimeRender HTML a where
111+ toByteString _ = cs . show
112+
113+instance Show a => MimeRender XML a where
114+ toByteString _ = cs . show
115+
116+instance IsString AcceptHeader where
117+ fromString = AcceptHeader . fromString
118+
119+addToAccept :: Accept a => Proxy a -> ZeroToOne -> AcceptHeader -> AcceptHeader
120+addToAccept p (ZeroToOne f) (AcceptHeader h) = AcceptHeader (cont h)
121+ where new = cs (show $ contentType p) `append` "; q=" `append` pack (show f)
122+ cont "" = new
123+ cont old = old `append` ", " `append` new
124+
125+newtype ZeroToOne = ZeroToOne Float
126+ deriving (Eq, Show, Ord)
127+
128+instance Arbitrary ZeroToOne where
129+ arbitrary = ZeroToOne <$> elements [ x / 10 | x <- [1..10]]
test/Servant/ServerSpec.hs+10−9
@@ -22,6 +22,7 @@ import Network.Wai.Test (runSession, request, defaultRequest, simpleBody)
2222import Test.Hspec (Spec, describe, it, shouldBe)
2323import Test.Hspec.Wai (liftIO, with, get, post, shouldRespondWith, matchStatus)
2424
25+import Servant.API (JSON)
2526import Servant.API.Capture (Capture)
2627import Servant.API.Get (Get)
2728import Servant.API.ReqBody (ReqBody)
@@ -79,7 +80,7 @@ spec = do
7980 errorsSpec
8081
8182
82−type CaptureApi = Capture "legs" Integer :> Get Animal
83+type CaptureApi = Capture "legs" Integer :> Get '[JSON] Animal
8384captureApi :: Proxy CaptureApi
8485captureApi = Proxy
8586captureServer :: Integer -> EitherT (Int, String) IO Animal
@@ -105,7 +106,7 @@ captureSpec = do
105106 get "/captured/foo" `shouldRespondWith` (fromString (show ["foo" :: String]))
106107
107108
108−type GetApi = Get Person
109+type GetApi = Get '[JSON] Person
109110getApi :: Proxy GetApi
110111getApi = Proxy
111112
@@ -123,9 +124,9 @@ getSpec = do
123124 post "/" "" `shouldRespondWith` 405
124125
125126
126−type QueryParamApi = QueryParam "name" String :> Get Person
127− :<|> "a" :> QueryParams "names" String :> Get Person
128− :<|> "b" :> QueryFlag "capitalize" :> Get Person
127+type QueryParamApi = QueryParam "name" String :> Get '[JSON] Person
128+ :<|> "a" :> QueryParams "names" String :> Get '[JSON] Person
129+ :<|> "b" :> QueryFlag "capitalize" :> Get '[JSON] Person
129130
130131queryParamApi :: Proxy QueryParamApi
131132queryParamApi = Proxy
@@ -289,8 +290,8 @@ matrixParamSpec = do
289290 }
290291
291292type PostApi =
292− ReqBody Person :> Post Integer
293− :<|> "bla" :> ReqBody Person :> Post Integer
293+ ReqBody Person :> Post '[JSON] Integer
294+ :<|> "bla" :> ReqBody Person :> Post '[JSON] Integer
294295postApi :: Proxy PostApi
295296postApi = Proxy
296297
@@ -344,8 +345,8 @@ rawSpec = do
344345
345346
346347type AlternativeApi =
347− "foo" :> Get Person
348− :<|> "bar" :> Get Animal
348+ "foo" :> Get '[JSON] Person
349+ :<|> "bar" :> Get '[JSON] Animal
349350unionApi :: Proxy AlternativeApi
350351unionApi = Proxy
351352
test/Servant/Utils/StaticFilesSpec.hs+2−1
@@ -13,6 +13,7 @@ import System.IO.Temp (withSystemTempDirectory)
1313import Test.Hspec (Spec, describe, it, around_)
1414import Test.Hspec.Wai (with, get, shouldRespondWith)
1515
16+import Servant.API (JSON)
1617import Servant.API.Alternative ((:<|>)((:<|>)))
1718import Servant.API.Capture (Capture)
1819import Servant.API.Get (Get)
@@ -23,7 +24,7 @@ import Servant.ServerSpec (Person(Person))
2324import Servant.Utils.StaticFiles (serveDirectory)
2425
2526type Api =
26− "dummy_api" :> Capture "person_name" String :> Get Person
27+ "dummy_api" :> Capture "person_name" String :> Get '[JSON] Person
2728 :<|> "static" :> Raw
2829
2930