Charset test fixes.

src/Servant/Server/ContentTypes.hs

@@ -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
+type family IsNonEmpty (ls::[*]) :: Constraint where
-    IsEmpty '[] = 'True
+    IsNonEmpty '[] = 'False ~ 'True
-    IsEmpty x   = 'False
+    IsNonEmpty x   = ()
 
 --------------------------------------------------------------------------
 -- * MimeUnrender Instances

test/Servant/Server/ContentTypesSpec.hs

@@ -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)
+            highest a b c = maximumBy (compare `on` snd) [ ("text/html;charset=utf-8", a)
-                                                      , ("application/json", b)
+                                                      , ("application/json;charset=utf-8", b)
-                                                      , ("application/xml", c)
+                                                      , ("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

test/Servant/ServerSpec.hs

@@ -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"{