@@ -1,131 +0,0 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE FlexibleInstances #-}
3−{-# LANGUAGE MultiParamTypeClasses #-}
4−{-# LANGUAGE OverloadedStrings #-}
5−{-# LANGUAGE TypeOperators #-}
6−{-# OPTIONS_GHC -fno-warn-orphans #-}
7−module Servant.Server.ContentTypesSpec where
8−
9−import Control.Applicative
10−import Data.Aeson (encode)
11−import Data.ByteString.Char8
12−import Data.Function (on)
13−import Data.Maybe (isJust, fromJust)
14−import Data.List (maximumBy)
15−import Data.Proxy (Proxy(..))
16−import qualified Data.Text.Lazy as T
17−import Data.String (IsString(..))
18−import Data.String.Conversions (cs)
19−import Network.HTTP.Types (hAccept)
20−import Network.Wai (pathInfo, requestHeaders)
21−import Network.Wai.Test ( runSession, request, defaultRequest
22− , assertContentType, assertStatus )
23−import Test.Hspec
24−import Test.QuickCheck
25−
26−import Servant.API
27−import Servant.API.ContentTypes
28−import Servant.Server
29−import Servant.Server.ContentTypes ()
30−
31−
32−spec :: Spec
33−spec = describe "Servant.Server.ContentTypes" $ do
34− handleAcceptHSpec
35− contentTypeSpec
36−
37−handleAcceptHSpec :: Spec
38−handleAcceptHSpec = describe "handleAcceptH" $ do
39−
40− it "should return Just if the 'Accept' header matches" $ do
41− handleAcceptH (Proxy :: Proxy '[JSON]) "*/*" (3 :: Int)
42− `shouldSatisfy` isJust
43− handleAcceptH (Proxy :: Proxy '[XML, JSON]) "application/json" (3 :: Int)
44− `shouldSatisfy` isJust
45− handleAcceptH (Proxy :: Proxy '[XML, JSON, HTML]) "text/html" (3 :: Int)
46− `shouldSatisfy` isJust
47−
48− it "should return the Content-Type as the first element of the tuple" $ do
49− handleAcceptH (Proxy :: Proxy '[JSON]) "*/*" (3 :: Int)
50− `shouldSatisfy` ((== "application/json;charset=utf-8") . fst . fromJust)
51− handleAcceptH (Proxy :: Proxy '[XML, JSON]) "application/json" (3 :: Int)
52− `shouldSatisfy` ((== "application/json;charset=utf-8") . fst . fromJust)
53− handleAcceptH (Proxy :: Proxy '[XML, JSON, HTML]) "text/html" (3 :: Int)
54− `shouldSatisfy` ((== "text/html;charset=utf-8") . fst . fromJust)
55−
56− it "should return the appropriately serialized representation" $ do
57− property $ \x -> handleAcceptH (Proxy :: Proxy '[JSON]) "*/*" (x :: Int)
58− == Just ("application/json;charset=utf-8", encode x)
59−
60− it "respects the Accept spec ordering" $
61− property $ \a b c i -> fst (fromJust $ val a b c i) == (fst $ highest a b c)
62− where
63− highest a b c = maximumBy (compare `on` snd) [ ("text/html;charset=utf-8", a)
64− , ("application/json;charset=utf-8", b)
65− , ("application/xml;charset=utf-8", c)
66− ]
67− acceptH a b c = addToAccept (Proxy :: Proxy HTML) a $
68− addToAccept (Proxy :: Proxy JSON) b $
69− addToAccept (Proxy :: Proxy XML ) c ""
70− val a b c i = handleAcceptH (Proxy :: Proxy '[HTML, JSON, XML])
71− (acceptH a b c) (i :: Int)
72−
73−type ContentTypeApi = "foo" :> Get '[JSON] Int
74− :<|> "bar" :> Get '[JSON, PlainText] T.Text
75−
76−contentTypeApi :: Proxy ContentTypeApi
77−contentTypeApi = Proxy
78−
79−contentTypeServer :: Server ContentTypeApi
80−contentTypeServer = return 5 :<|> return "hi"
81−
82−contentTypeSpec :: Spec
83−contentTypeSpec = do
84− describe "Accept Headers" $ do
85−
86− it "uses the highest quality possible in the header" $
87− flip runSession (serve contentTypeApi contentTypeServer) $ do
88− let acceptH = "text/plain; q=0.9, application/json; q=0.8"
89− response <- Network.Wai.Test.request defaultRequest{
90− requestHeaders = [(hAccept, acceptH)] ,
91− pathInfo = ["bar"]
92− }
93− assertContentType "text/plain;charset=utf8" response
94−
95− it "returns the first content-type if the Accept header is missing" $
96− flip runSession (serve contentTypeApi contentTypeServer) $ do
97− response <- Network.Wai.Test.request defaultRequest{
98− pathInfo = ["bar"]
99− }
100− assertContentType "application/json;charset=utf8" response
101−
102− it "returns 406 if it can't serve the requested content-type" $
103− flip runSession (serve contentTypeApi contentTypeServer) $ do
104− let acceptH = "text/css"
105− response <- Network.Wai.Test.request defaultRequest{
106− requestHeaders = [(hAccept, acceptH)] ,
107− pathInfo = ["bar"]
108− }
109− assertStatus 406 response
110−
111−
112−instance Show a => MimeRender HTML a where
113− toByteString _ = cs . show
114−
115−instance Show a => MimeRender XML a where
116− toByteString _ = cs . show
117−
118−instance IsString AcceptHeader where
119− fromString = AcceptHeader . fromString
120−
121−addToAccept :: Accept a => Proxy a -> ZeroToOne -> AcceptHeader -> AcceptHeader
122−addToAccept p (ZeroToOne f) (AcceptHeader h) = AcceptHeader (cont h)
123− where new = cs (show $ contentType p) `append` "; q=" `append` pack (show f)
124− cont "" = new
125− cont old = old `append` ", " `append` new
126−
127−newtype ZeroToOne = ZeroToOne Float
128− deriving (Eq, Show, Ord)
129−
130−instance Arbitrary ZeroToOne where
131− arbitrary = ZeroToOne <$> elements [ x / 10 | x <- [1..10]]