Charset test fixes.
This commit is contained in:
parent
8028cceee7
commit
2092ddc201
3 changed files with 25 additions and 22 deletions
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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"{
|
||||
|
|
Loading…
Reference in a new issue