2092ddc · servant · git.iko.soy

git.iko.soy/servant

Charset test fixes.

commit2092ddc20142ca03575fcb8f603932f871206349 authorJulian K. Arni <jkarni@gmail.com> dateTue 13 Jan 2015, 22:40 (12 years ago) parent8028cce

3 files changed+25−22

compare with master

unifiedsplit

src/Servant/Server/ContentTypes.hs+12−10 test/Servant/Server/ContentTypesSpec.hs+12−11 test/Servant/ServerSpec.hs+1−1

src/Servant/Server/ContentTypes.hs+12−10

@@ -1,4 +1,5 @@

11{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE ConstraintKinds #-}

23{-# LANGUAGE FlexibleInstances #-}

34{-# LANGUAGE MultiParamTypeClasses #-}

45{-# LANGUAGE OverloadedStrings #-}

@@ -17,6 +18,7 @@ import Data.Proxy (Proxy(..))

1718import Data.String.Conversions (cs)

1819import qualified Data.Text.Lazy.Encoding as Text

1920import qualified Data.Text.Lazy as Text

21+import GHC.Exts (Constraint)

2022import qualified Network.HTTP.Media as M

2123

2224

@@ -39,7 +41,7 @@ class Accept ctype where

3941

4042-- | @text/html;charset=utf-8@

4143instance Accept HTML where

42− contentType _ = "text" M.// "html"

44+ contentType _ = "text" M.// "html" M./: ("charset", "utf-8")

4345

4446-- | @application/json;charset=utf-8@

4547instance Accept JSON where

@@ -47,19 +49,19 @@ instance Accept JSON where

4749

4850-- | @application/xml;charset=utf-8@

4951instance Accept XML where

50− contentType _ = "application" M.// "xml"

52+ contentType _ = "application" M.// "xml" M./: ("charset", "utf-8")

5153

5254-- | @application/javascript;charset=utf-8@

5355instance Accept JavaScript where

54− contentType _ = "application" M.// "javascript"

56+ contentType _ = "application" M.// "javascript" M./: ("charset", "utf-8")

5557

5658-- | @text/css;charset=utf-8@

5759instance Accept CSS where

58− contentType _ = "text" M.// "css"

60+ contentType _ = "text" M.// "css" M./: ("charset", "utf-8")

5961

6062-- | @text/plain;charset=utf-8@

6163instance Accept PlainText where

62− contentType _ = "text" M.// "plain"

64+ contentType _ = "text" M.// "plain" M./: ("charset", "utf-8")

6365

6466-- | @application/octet-stream@

6567instance Accept OctetStream where

@@ -93,7 +95,7 @@ class AllCTRender list a where

9395 -- mimetype).

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

9597

96−instance ( AllMimeRender ctyps a, IsEmpty ctyps ~ 'False

98+instance ( AllMimeRender ctyps a, IsNonEmpty ctyps

9799 ) => AllCTRender ctyps a where

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

99101 where pctyps = Proxy :: Proxy ctyps

@@ -125,7 +127,7 @@ class AllCTUnrender list a where

125127 -> ByteString -- Request body

126128 -> Maybe a

127129

128−instance ( AllMimeUnrender ctyps a, IsEmpty ctyps ~ 'False

130+instance ( AllMimeUnrender ctyps a, IsNonEmpty ctyps

129131 ) => AllCTUnrender ctyps a where

130132 handleCTypeH _ ctypeH body = join $ M.mapContentMedia lkup (cs ctypeH)

131133 where lkup = amu (Proxy :: Proxy ctyps) body

@@ -182,9 +184,9 @@ instance ( MimeUnrender ctyp a

182184 pctyps = Proxy :: Proxy ctyps

183185 pctyp' = Proxy :: Proxy ctyp'

184186

185−type family IsEmpty (ls::[*]) where

186− IsEmpty '[] = 'True

187− IsEmpty x = 'False

187+type family IsNonEmpty (ls::[*]) :: Constraint where

188+ IsNonEmpty '[] = 'False ~ 'True

189+ IsNonEmpty x = ()

188190

189191--------------------------------------------------------------------------

190192-- * MimeUnrender Instances

test/Servant/Server/ContentTypesSpec.hs+12−11

@@ -13,6 +13,7 @@ import Data.Function (on)

1313import Data.Maybe (isJust, fromJust)

1414import Data.List (maximumBy)

1515import Data.Proxy (Proxy(..))

16+import qualified Data.Text.Lazy as T

1617import Data.String (IsString(..))

1718import Data.String.Conversions (cs)

1819import Network.HTTP.Types (hAccept)

@@ -45,22 +46,22 @@ handleAcceptHSpec = describe "handleAcceptH" $ do

4546

4647 it "should return the Content-Type as the first element of the tuple" $ do

4748 handleAcceptH (Proxy :: Proxy '[JSON]) "*/*" (3 :: Int)

48− `shouldSatisfy` ((== "application/json") . fst . fromJust)

49+ `shouldSatisfy` ((== "application/json;charset=utf-8") . fst . fromJust)

4950 handleAcceptH (Proxy :: Proxy '[XML, JSON]) "application/json" (3 :: Int)

50− `shouldSatisfy` ((== "application/json") . fst . fromJust)

51+ `shouldSatisfy` ((== "application/json;charset=utf-8") . fst . fromJust)

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

5354

5455 it "should return the appropriately serialized representation" $ do

5556 property $ \x -> handleAcceptH (Proxy :: Proxy '[JSON]) "*/*" (x :: Int)

56− == Just ("application/json", encode x)

57+ == Just ("application/json;charset=utf-8", encode x)

5758

5859 it "respects the Accept spec ordering" $

5960 property $ \a b c i -> fst (fromJust $ val a b c i) == (fst $ highest a b c)

6061 where

61− highest a b c = maximumBy (compare `on` snd) [ ("text/html", a)

62− , ("application/json", b)

63− , ("application/xml", c)

62+ highest a b c = maximumBy (compare `on` snd) [ ("text/html;charset=utf-8", a)

63+ , ("application/json;charset=utf-8", b)

64+ , ("application/xml;charset=utf-8", c)

6465 ]

6566 acceptH a b c = addToAccept (Proxy :: Proxy HTML) a $

6667 addToAccept (Proxy :: Proxy JSON) b $

@@ -69,13 +70,13 @@ handleAcceptHSpec = describe "handleAcceptH" $ do

6970 (acceptH a b c) (i :: Int)

7071

7172type ContentTypeApi = "foo" :> Get '[JSON] Int

72− :<|> "bar" :> Get '[JSON, PlainText] Int

73+ :<|> "bar" :> Get '[JSON, PlainText] T.Text

7374

7475contentTypeApi :: Proxy ContentTypeApi

7576contentTypeApi = Proxy

7677

7778contentTypeServer :: Server ContentTypeApi

78−contentTypeServer = return 5 :<|> return 3

79+contentTypeServer = return 5 :<|> return "hi"

7980

8081contentTypeSpec :: Spec

8182contentTypeSpec = do

@@ -88,14 +89,14 @@ contentTypeSpec = do

8889 requestHeaders = [(hAccept, acceptH)] ,

8990 pathInfo = ["bar"]

9091 }

91− assertContentType "text/plain" response

92+ assertContentType "text/plain;charset=utf8" response

9293

9394 it "returns the first content-type if the Accept header is missing" $

9495 flip runSession (serve contentTypeApi contentTypeServer) $ do

9596 response <- Network.Wai.Test.request defaultRequest{

9697 pathInfo = ["bar"]

9798 }

98− assertContentType "application/json" response

99+ assertContentType "application/json;charset=utf8" response

99100

100101 it "returns 406 if it can't serve the requested content-type" $

101102 flip runSession (serve contentTypeApi contentTypeServer) $ do

test/Servant/ServerSpec.hs+1−1

@@ -303,7 +303,7 @@ postSpec = do

303303 describe "Servant.API.Post and .ReqBody" $ do

304304 with (return (serve postApi (return . age :<|> return . age))) $ do

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

306− , "application/json")]

306+ , "application/json;charset=utf-8")]

307307

308308 it "allows to POST a Person" $ do

309309 post' "/" (encode alice) `shouldRespondWith` "42"{