130 lines
5.1 KiB
Haskell
130 lines
5.1 KiB
Haskell
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE TypeOperators #-}
|
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
module Servant.Server.ContentTypesSpec where
|
|
|
|
import Control.Applicative
|
|
import Data.Aeson (encode)
|
|
import Data.ByteString.Char8
|
|
import Data.Function (on)
|
|
import Data.Maybe (isJust, fromJust)
|
|
import Data.List (maximumBy)
|
|
import Data.Proxy (Proxy(..))
|
|
import Data.String (IsString(..))
|
|
import Data.String.Conversions (cs)
|
|
import Network.HTTP.Types (hAccept)
|
|
import Network.Wai (pathInfo, requestHeaders)
|
|
import Network.Wai.Test ( runSession, request, defaultRequest
|
|
, assertContentType, assertStatus )
|
|
import Test.Hspec
|
|
import Test.QuickCheck
|
|
|
|
import Servant.API
|
|
import Servant.Server
|
|
import Servant.Server.ContentTypes
|
|
|
|
|
|
spec :: Spec
|
|
spec = describe "Servant.Server.ContentTypes" $ do
|
|
handleAcceptHSpec
|
|
contentTypeSpec
|
|
|
|
handleAcceptHSpec :: Spec
|
|
handleAcceptHSpec = describe "handleAcceptH" $ do
|
|
|
|
it "should return Just if the 'Accept' header matches" $ do
|
|
handleAcceptH (Proxy :: Proxy '[JSON]) "*/*" (3 :: Int)
|
|
`shouldSatisfy` isJust
|
|
handleAcceptH (Proxy :: Proxy '[XML, JSON]) "application/json" (3 :: Int)
|
|
`shouldSatisfy` isJust
|
|
handleAcceptH (Proxy :: Proxy '[XML, JSON, HTML]) "text/html" (3 :: Int)
|
|
`shouldSatisfy` isJust
|
|
|
|
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)
|
|
handleAcceptH (Proxy :: Proxy '[XML, JSON]) "application/json" (3 :: Int)
|
|
`shouldSatisfy` ((== "application/json") . fst . fromJust)
|
|
handleAcceptH (Proxy :: Proxy '[XML, JSON, HTML]) "text/html" (3 :: Int)
|
|
`shouldSatisfy` ((== "text/html") . fst . fromJust)
|
|
|
|
it "should return the appropriately serialized representation" $ do
|
|
property $ \x -> handleAcceptH (Proxy :: Proxy '[JSON]) "*/*" (x :: Int)
|
|
== Just ("application/json", 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)
|
|
]
|
|
acceptH a b c = addToAccept (Proxy :: Proxy HTML) a $
|
|
addToAccept (Proxy :: Proxy JSON) b $
|
|
addToAccept (Proxy :: Proxy XML ) c ""
|
|
val a b c i = handleAcceptH (Proxy :: Proxy '[HTML, JSON, XML])
|
|
(acceptH a b c) (i :: Int)
|
|
|
|
type ContentTypeApi = "foo" :> Get '[JSON] Int
|
|
:<|> "bar" :> Get '[JSON, PlainText] Int
|
|
|
|
contentTypeApi :: Proxy ContentTypeApi
|
|
contentTypeApi = Proxy
|
|
|
|
contentTypeServer :: Server ContentTypeApi
|
|
contentTypeServer = return 5 :<|> return 3
|
|
|
|
contentTypeSpec :: Spec
|
|
contentTypeSpec = do
|
|
describe "Accept Headers" $ do
|
|
|
|
it "uses the highest quality possible in the header" $
|
|
flip runSession (serve contentTypeApi contentTypeServer) $ do
|
|
let acceptH = "text/plain; q=0.9, application/json; q=0.8"
|
|
response <- Network.Wai.Test.request defaultRequest{
|
|
requestHeaders = [(hAccept, acceptH)] ,
|
|
pathInfo = ["bar"]
|
|
}
|
|
assertContentType "text/plain" 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
|
|
|
|
it "returns 406 if it can't serve the requested content-type" $
|
|
flip runSession (serve contentTypeApi contentTypeServer) $ do
|
|
let acceptH = "text/css"
|
|
response <- Network.Wai.Test.request defaultRequest{
|
|
requestHeaders = [(hAccept, acceptH)] ,
|
|
pathInfo = ["bar"]
|
|
}
|
|
assertStatus 406 response
|
|
|
|
|
|
instance Show a => MimeRender HTML a where
|
|
toByteString _ = cs . show
|
|
|
|
instance Show a => MimeRender XML a where
|
|
toByteString _ = cs . show
|
|
|
|
instance IsString AcceptHeader where
|
|
fromString = AcceptHeader . fromString
|
|
|
|
addToAccept :: Accept a => Proxy a -> ZeroToOne -> AcceptHeader -> AcceptHeader
|
|
addToAccept p (ZeroToOne f) (AcceptHeader h) = AcceptHeader (cont h)
|
|
where new = cs (show $ contentType p) `append` "; q=" `append` pack (show f)
|
|
cont "" = new
|
|
cont old = old `append` ", " `append` new
|
|
|
|
newtype ZeroToOne = ZeroToOne Float
|
|
deriving (Eq, Show, Ord)
|
|
|
|
instance Arbitrary ZeroToOne where
|
|
arbitrary = ZeroToOne <$> elements [ x / 10 | x <- [1..10]]
|