Charset test fixes.

This commit is contained in:
Julian K. Arni 2015-01-13 22:40:41 +01:00
parent 8028cceee7
commit 2092ddc201
3 changed files with 25 additions and 22 deletions

View file

@ -1,4 +1,5 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
@ -17,6 +18,7 @@ import Data.Proxy (Proxy(..))
import Data.String.Conversions (cs)
import qualified Data.Text.Lazy.Encoding as Text
import qualified Data.Text.Lazy as Text
import GHC.Exts (Constraint)
import qualified Network.HTTP.Media as M
@ -39,7 +41,7 @@ class Accept ctype where
-- | @text/html;charset=utf-8@
instance Accept HTML where
contentType _ = "text" M.// "html"
contentType _ = "text" M.// "html" M./: ("charset", "utf-8")
-- | @application/json;charset=utf-8@
instance Accept JSON where
@ -47,19 +49,19 @@ instance Accept JSON where
-- | @application/xml;charset=utf-8@
instance Accept XML where
contentType _ = "application" M.// "xml"
contentType _ = "application" M.// "xml" M./: ("charset", "utf-8")
-- | @application/javascript;charset=utf-8@
instance Accept JavaScript where
contentType _ = "application" M.// "javascript"
contentType _ = "application" M.// "javascript" M./: ("charset", "utf-8")
-- | @text/css;charset=utf-8@
instance Accept CSS where
contentType _ = "text" M.// "css"
contentType _ = "text" M.// "css" M./: ("charset", "utf-8")
-- | @text/plain;charset=utf-8@
instance Accept PlainText where
contentType _ = "text" M.// "plain"
contentType _ = "text" M.// "plain" M./: ("charset", "utf-8")
-- | @application/octet-stream@
instance Accept OctetStream where
@ -93,7 +95,7 @@ class AllCTRender list a where
-- mimetype).
handleAcceptH :: Proxy list -> AcceptHeader -> a -> Maybe (ByteString, ByteString)
instance ( AllMimeRender ctyps a, IsEmpty ctyps ~ 'False
instance ( AllMimeRender ctyps a, IsNonEmpty ctyps
) => AllCTRender ctyps a where
handleAcceptH _ (AcceptHeader accept) val = M.mapAcceptMedia lkup accept
where pctyps = Proxy :: Proxy ctyps
@ -125,7 +127,7 @@ class AllCTUnrender list a where
-> ByteString -- Request body
-> Maybe a
instance ( AllMimeUnrender ctyps a, IsEmpty ctyps ~ 'False
instance ( AllMimeUnrender ctyps a, IsNonEmpty ctyps
) => AllCTUnrender ctyps a where
handleCTypeH _ ctypeH body = join $ M.mapContentMedia lkup (cs ctypeH)
where lkup = amu (Proxy :: Proxy ctyps) body
@ -182,9 +184,9 @@ instance ( MimeUnrender ctyp a
pctyps = Proxy :: Proxy ctyps
pctyp' = Proxy :: Proxy ctyp'
type family IsEmpty (ls::[*]) where
IsEmpty '[] = 'True
IsEmpty x = 'False
type family IsNonEmpty (ls::[*]) :: Constraint where
IsNonEmpty '[] = 'False ~ 'True
IsNonEmpty x = ()
--------------------------------------------------------------------------
-- * MimeUnrender Instances

View file

@ -13,6 +13,7 @@ import Data.Function (on)
import Data.Maybe (isJust, fromJust)
import Data.List (maximumBy)
import Data.Proxy (Proxy(..))
import qualified Data.Text.Lazy as T
import Data.String (IsString(..))
import Data.String.Conversions (cs)
import Network.HTTP.Types (hAccept)
@ -45,22 +46,22 @@ handleAcceptHSpec = describe "handleAcceptH" $ do
it "should return the Content-Type as the first element of the tuple" $ do
handleAcceptH (Proxy :: Proxy '[JSON]) "*/*" (3 :: Int)
`shouldSatisfy` ((== "application/json") . fst . fromJust)
`shouldSatisfy` ((== "application/json;charset=utf-8") . fst . fromJust)
handleAcceptH (Proxy :: Proxy '[XML, JSON]) "application/json" (3 :: Int)
`shouldSatisfy` ((== "application/json") . fst . fromJust)
`shouldSatisfy` ((== "application/json;charset=utf-8") . fst . fromJust)
handleAcceptH (Proxy :: Proxy '[XML, JSON, HTML]) "text/html" (3 :: Int)
`shouldSatisfy` ((== "text/html") . fst . fromJust)
`shouldSatisfy` ((== "text/html;charset=utf-8") . fst . fromJust)
it "should return the appropriately serialized representation" $ do
property $ \x -> handleAcceptH (Proxy :: Proxy '[JSON]) "*/*" (x :: Int)
== Just ("application/json", encode x)
== Just ("application/json;charset=utf-8", encode x)
it "respects the Accept spec ordering" $
property $ \a b c i -> fst (fromJust $ val a b c i) == (fst $ highest a b c)
where
highest a b c = maximumBy (compare `on` snd) [ ("text/html", a)
, ("application/json", b)
, ("application/xml", c)
highest a b c = maximumBy (compare `on` snd) [ ("text/html;charset=utf-8", a)
, ("application/json;charset=utf-8", b)
, ("application/xml;charset=utf-8", c)
]
acceptH a b c = addToAccept (Proxy :: Proxy HTML) a $
addToAccept (Proxy :: Proxy JSON) b $
@ -69,13 +70,13 @@ handleAcceptHSpec = describe "handleAcceptH" $ do
(acceptH a b c) (i :: Int)
type ContentTypeApi = "foo" :> Get '[JSON] Int
:<|> "bar" :> Get '[JSON, PlainText] Int
:<|> "bar" :> Get '[JSON, PlainText] T.Text
contentTypeApi :: Proxy ContentTypeApi
contentTypeApi = Proxy
contentTypeServer :: Server ContentTypeApi
contentTypeServer = return 5 :<|> return 3
contentTypeServer = return 5 :<|> return "hi"
contentTypeSpec :: Spec
contentTypeSpec = do
@ -88,14 +89,14 @@ contentTypeSpec = do
requestHeaders = [(hAccept, acceptH)] ,
pathInfo = ["bar"]
}
assertContentType "text/plain" response
assertContentType "text/plain;charset=utf8" response
it "returns the first content-type if the Accept header is missing" $
flip runSession (serve contentTypeApi contentTypeServer) $ do
response <- Network.Wai.Test.request defaultRequest{
pathInfo = ["bar"]
}
assertContentType "application/json" response
assertContentType "application/json;charset=utf8" response
it "returns 406 if it can't serve the requested content-type" $
flip runSession (serve contentTypeApi contentTypeServer) $ do

View file

@ -303,7 +303,7 @@ postSpec = do
describe "Servant.API.Post and .ReqBody" $ do
with (return (serve postApi (return . age :<|> return . age))) $ do
let post' x = Test.Hspec.Wai.request methodPost x [(hContentType
, "application/json")]
, "application/json;charset=utf-8")]
it "allows to POST a Person" $ do
post' "/" (encode alice) `shouldRespondWith` "42"{