git.iko.soy/servant
on master help sign in
Charset test fixes.
2092ddcJulian K. Arni
src/Servant/Server/ContentTypes.hs+12−10
compare with master
unifiedsplit
@@ -1,4 +1,5 @@
1{-# LANGUAGE DataKinds #-}
1{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE MultiParamTypeClasses #-}
4{-# LANGUAGE MultiParamTypeClasses #-}
4{-# LANGUAGE OverloadedStrings #-}
5{-# LANGUAGE OverloadedStrings #-}
@@ -17,6 +18,7 @@ import Data.Proxy (Proxy(..))
17import Data.String.Conversions (cs)
18import Data.String.Conversions (cs)
18import qualified Data.Text.Lazy.Encoding as Text
19import qualified Data.Text.Lazy.Encoding as Text
19import qualified Data.Text.Lazy as Text
20import qualified Data.Text.Lazy as Text
21+import GHC.Exts (Constraint)
20import qualified Network.HTTP.Media as M
22import qualified Network.HTTP.Media as M
21
23
22
24
@@ -39,7 +41,7 @@ class Accept ctype where
39
41
40-- | @text/html;charset=utf-8@
42-- | @text/html;charset=utf-8@
41instance Accept HTML where
43instance Accept HTML where
42− contentType _ = "text" M.// "html"
44+ contentType _ = "text" M.// "html" M./: ("charset", "utf-8")
43
45
44-- | @application/json;charset=utf-8@
46-- | @application/json;charset=utf-8@
45instance Accept JSON where
47instance Accept JSON where
@@ -47,19 +49,19 @@ instance Accept JSON where
47
49
48-- | @application/xml;charset=utf-8@
50-- | @application/xml;charset=utf-8@
49instance Accept XML where
51instance Accept XML where
50− contentType _ = "application" M.// "xml"
52+ contentType _ = "application" M.// "xml" M./: ("charset", "utf-8")
51
53
52-- | @application/javascript;charset=utf-8@
54-- | @application/javascript;charset=utf-8@
53instance Accept JavaScript where
55instance Accept JavaScript where
54− contentType _ = "application" M.// "javascript"
56+ contentType _ = "application" M.// "javascript" M./: ("charset", "utf-8")
55
57
56-- | @text/css;charset=utf-8@
58-- | @text/css;charset=utf-8@
57instance Accept CSS where
59instance Accept CSS where
58− contentType _ = "text" M.// "css"
60+ contentType _ = "text" M.// "css" M./: ("charset", "utf-8")
59
61
60-- | @text/plain;charset=utf-8@
62-- | @text/plain;charset=utf-8@
61instance Accept PlainText where
63instance Accept PlainText where
62− contentType _ = "text" M.// "plain"
64+ contentType _ = "text" M.// "plain" M./: ("charset", "utf-8")
63
65
64-- | @application/octet-stream@
66-- | @application/octet-stream@
65instance Accept OctetStream where
67instance Accept OctetStream where
@@ -93,7 +95,7 @@ class AllCTRender list a where
93 -- mimetype).
95 -- mimetype).
94 handleAcceptH :: Proxy list -> AcceptHeader -> a -> Maybe (ByteString, ByteString)
96 handleAcceptH :: Proxy list -> AcceptHeader -> a -> Maybe (ByteString, ByteString)
95
97
96−instance ( AllMimeRender ctyps a, IsEmpty ctyps ~ 'False
98+instance ( AllMimeRender ctyps a, IsNonEmpty ctyps
97 ) => AllCTRender ctyps a where
99 ) => AllCTRender ctyps a where
98 handleAcceptH _ (AcceptHeader accept) val = M.mapAcceptMedia lkup accept
100 handleAcceptH _ (AcceptHeader accept) val = M.mapAcceptMedia lkup accept
99 where pctyps = Proxy :: Proxy ctyps
101 where pctyps = Proxy :: Proxy ctyps
@@ -125,7 +127,7 @@ class AllCTUnrender list a where
125 -> ByteString -- Request body
127 -> ByteString -- Request body
126 -> Maybe a
128 -> Maybe a
127
129
128−instance ( AllMimeUnrender ctyps a, IsEmpty ctyps ~ 'False
130+instance ( AllMimeUnrender ctyps a, IsNonEmpty ctyps
129 ) => AllCTUnrender ctyps a where
131 ) => AllCTUnrender ctyps a where
130 handleCTypeH _ ctypeH body = join $ M.mapContentMedia lkup (cs ctypeH)
132 handleCTypeH _ ctypeH body = join $ M.mapContentMedia lkup (cs ctypeH)
131 where lkup = amu (Proxy :: Proxy ctyps) body
133 where lkup = amu (Proxy :: Proxy ctyps) body
@@ -182,9 +184,9 @@ instance ( MimeUnrender ctyp a
182 pctyps = Proxy :: Proxy ctyps
184 pctyps = Proxy :: Proxy ctyps
183 pctyp' = Proxy :: Proxy ctyp'
185 pctyp' = Proxy :: Proxy ctyp'
184
186
185−type family IsEmpty (ls::[*]) where
187+type family IsNonEmpty (ls::[*]) :: Constraint where
186− IsEmpty '[] = 'True
188+ IsNonEmpty '[] = 'False ~ 'True
187− IsEmpty x = 'False
189+ IsNonEmpty x = ()
188
190
189--------------------------------------------------------------------------
191--------------------------------------------------------------------------
190-- * MimeUnrender Instances
192-- * MimeUnrender Instances
test/Servant/Server/ContentTypesSpec.hs+12−11
@@ -13,6 +13,7 @@ import Data.Function (on)
13import Data.Maybe (isJust, fromJust)
13import Data.Maybe (isJust, fromJust)
14import Data.List (maximumBy)
14import Data.List (maximumBy)
15import Data.Proxy (Proxy(..))
15import Data.Proxy (Proxy(..))
16+import qualified Data.Text.Lazy as T
16import Data.String (IsString(..))
17import Data.String (IsString(..))
17import Data.String.Conversions (cs)
18import Data.String.Conversions (cs)
18import Network.HTTP.Types (hAccept)
19import Network.HTTP.Types (hAccept)
@@ -45,22 +46,22 @@ handleAcceptHSpec = describe "handleAcceptH" $ do
45
46
46 it "should return the Content-Type as the first element of the tuple" $ do
47 it "should return the Content-Type as the first element of the tuple" $ do
47 handleAcceptH (Proxy :: Proxy '[JSON]) "*/*" (3 :: Int)
48 handleAcceptH (Proxy :: Proxy '[JSON]) "*/*" (3 :: Int)
48− `shouldSatisfy` ((== "application/json") . fst . fromJust)
49+ `shouldSatisfy` ((== "application/json;charset=utf-8") . fst . fromJust)
49 handleAcceptH (Proxy :: Proxy '[XML, JSON]) "application/json" (3 :: Int)
50 handleAcceptH (Proxy :: Proxy '[XML, JSON]) "application/json" (3 :: Int)
50− `shouldSatisfy` ((== "application/json") . fst . fromJust)
51+ `shouldSatisfy` ((== "application/json;charset=utf-8") . fst . fromJust)
51 handleAcceptH (Proxy :: Proxy '[XML, JSON, HTML]) "text/html" (3 :: Int)
52 handleAcceptH (Proxy :: Proxy '[XML, JSON, HTML]) "text/html" (3 :: Int)
52− `shouldSatisfy` ((== "text/html") . fst . fromJust)
53+ `shouldSatisfy` ((== "text/html;charset=utf-8") . fst . fromJust)
53
54
54 it "should return the appropriately serialized representation" $ do
55 it "should return the appropriately serialized representation" $ do
55 property $ \x -> handleAcceptH (Proxy :: Proxy '[JSON]) "*/*" (x :: Int)
56 property $ \x -> handleAcceptH (Proxy :: Proxy '[JSON]) "*/*" (x :: Int)
56− == Just ("application/json", encode x)
57+ == Just ("application/json;charset=utf-8", encode x)
57
58
58 it "respects the Accept spec ordering" $
59 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 property $ \a b c i -> fst (fromJust $ val a b c i) == (fst $ highest a b c)
60 where
61 where
61− highest a b c = maximumBy (compare `on` snd) [ ("text/html", a)
62+ highest a b c = maximumBy (compare `on` snd) [ ("text/html;charset=utf-8", a)
62− , ("application/json", b)
63+ , ("application/json;charset=utf-8", b)
63− , ("application/xml", c)
64+ , ("application/xml;charset=utf-8", c)
64 ]
65 ]
65 acceptH a b c = addToAccept (Proxy :: Proxy HTML) a $
66 acceptH a b c = addToAccept (Proxy :: Proxy HTML) a $
66 addToAccept (Proxy :: Proxy JSON) b $
67 addToAccept (Proxy :: Proxy JSON) b $
@@ -69,13 +70,13 @@ handleAcceptHSpec = describe "handleAcceptH" $ do
69 (acceptH a b c) (i :: Int)
70 (acceptH a b c) (i :: Int)
70
71
71type ContentTypeApi = "foo" :> Get '[JSON] Int
72type ContentTypeApi = "foo" :> Get '[JSON] Int
72− :<|> "bar" :> Get '[JSON, PlainText] Int
73+ :<|> "bar" :> Get '[JSON, PlainText] T.Text
73
74
74contentTypeApi :: Proxy ContentTypeApi
75contentTypeApi :: Proxy ContentTypeApi
75contentTypeApi = Proxy
76contentTypeApi = Proxy
76
77
77contentTypeServer :: Server ContentTypeApi
78contentTypeServer :: Server ContentTypeApi
78−contentTypeServer = return 5 :<|> return 3
79+contentTypeServer = return 5 :<|> return "hi"
79
80
80contentTypeSpec :: Spec
81contentTypeSpec :: Spec
81contentTypeSpec = do
82contentTypeSpec = do
@@ -88,14 +89,14 @@ contentTypeSpec = do
88 requestHeaders = [(hAccept, acceptH)] ,
89 requestHeaders = [(hAccept, acceptH)] ,
89 pathInfo = ["bar"]
90 pathInfo = ["bar"]
90 }
91 }
91− assertContentType "text/plain" response
92+ assertContentType "text/plain;charset=utf8" response
92
93
93 it "returns the first content-type if the Accept header is missing" $
94 it "returns the first content-type if the Accept header is missing" $
94 flip runSession (serve contentTypeApi contentTypeServer) $ do
95 flip runSession (serve contentTypeApi contentTypeServer) $ do
95 response <- Network.Wai.Test.request defaultRequest{
96 response <- Network.Wai.Test.request defaultRequest{
96 pathInfo = ["bar"]
97 pathInfo = ["bar"]
97 }
98 }
98− assertContentType "application/json" response
99+ assertContentType "application/json;charset=utf8" response
99
100
100 it "returns 406 if it can't serve the requested content-type" $
101 it "returns 406 if it can't serve the requested content-type" $
101 flip runSession (serve contentTypeApi contentTypeServer) $ do
102 flip runSession (serve contentTypeApi contentTypeServer) $ do
test/Servant/ServerSpec.hs+1−1
@@ -303,7 +303,7 @@ postSpec = do
303 describe "Servant.API.Post and .ReqBody" $ do
303 describe "Servant.API.Post and .ReqBody" $ do
304 with (return (serve postApi (return . age :<|> return . age))) $ do
304 with (return (serve postApi (return . age :<|> return . age))) $ do
305 let post' x = Test.Hspec.Wai.request methodPost x [(hContentType
305 let post' x = Test.Hspec.Wai.request methodPost x [(hContentType
306− , "application/json")]
306+ , "application/json;charset=utf-8")]
307
307
308 it "allows to POST a Person" $ do
308 it "allows to POST a Person" $ do
309 post' "/" (encode alice) `shouldRespondWith` "42"{
309 post' "/" (encode alice) `shouldRespondWith` "42"{