Remove ContentTypes.hs
This commit is contained in:
Julian K. Arni
parent
e9f3341b9e
commit
0789682cf8
|
|
@ -31,7 +31,6 @@ library
|
|||
exposed-modules:
|
||||
Servant
|
||||
Servant.Server
|
||||
Servant.Server.ContentTypes
|
||||
Servant.Server.Internal
|
||||
Servant.Utils.StaticFiles
|
||||
build-depends:
|
||||
|
|
@ -40,7 +39,6 @@ library
|
|||
, attoparsec >= 0.12 && < 0.13
|
||||
, bytestring >= 0.10 && < 0.11
|
||||
, either >= 4.3 && < 4.4
|
||||
, http-media >= 0.4 && < 0.5
|
||||
, http-types >= 0.8 && < 0.9
|
||||
, network-uri >= 2.6 && < 2.7
|
||||
, safe >= 0.3 && < 0.4
|
||||
|
|
|
|||
|
|
@ -8,7 +8,6 @@ module Servant (
|
|||
-- | Using your types in request paths and query string parameters
|
||||
module Servant.Common.Text,
|
||||
-- | Utilities on top of the servant core
|
||||
module Servant.QQ,
|
||||
module Servant.Utils.Links,
|
||||
module Servant.Utils.StaticFiles,
|
||||
-- | Useful re-exports
|
||||
|
|
@ -19,6 +18,5 @@ import Data.Proxy
|
|||
import Servant.API
|
||||
import Servant.Common.Text
|
||||
import Servant.Server
|
||||
import Servant.QQ
|
||||
import Servant.Utils.Links
|
||||
import Servant.Utils.StaticFiles
|
||||
|
|
|
|||
|
|
@ -16,7 +16,6 @@ import Data.Proxy (Proxy)
|
|||
import Network.Wai (Application)
|
||||
|
||||
import Servant.Server.Internal
|
||||
import Servant.Server.ContentTypes ()
|
||||
|
||||
|
||||
-- * Implementing Servers
|
||||
|
|
|
|||
|
|
@ -1,51 +0,0 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
module Servant.Server.ContentTypes where
|
||||
|
||||
import Control.Monad (join)
|
||||
import Control.Arrow (left)
|
||||
import Data.Aeson (ToJSON(..), FromJSON(..), encode, eitherDecode)
|
||||
import Data.ByteString.Lazy (ByteString)
|
||||
import qualified Data.ByteString as BS
|
||||
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
|
||||
|
||||
|
||||
import Servant.API ( XML, HTML, JSON, JavaScript, CSS, PlainText
|
||||
, OctetStream, MimeRender(..), MimeUnrender(..) )
|
||||
|
||||
|
||||
--------------------------------------------------------------------------
|
||||
-- * MimeRender Instances
|
||||
|
||||
-- | @encode@
|
||||
instance ToJSON a => MimeRender JSON a where
|
||||
toByteString _ = encode
|
||||
|
||||
-- | @encodeUtf8@
|
||||
instance MimeRender PlainText Text.Text where
|
||||
toByteString _ = Text.encodeUtf8
|
||||
|
||||
--------------------------------------------------------------------------
|
||||
-- * MimeUnrender Instances
|
||||
|
||||
-- | @decode@
|
||||
instance FromJSON a => MimeUnrender JSON a where
|
||||
fromByteString _ = eitherDecode
|
||||
|
||||
-- | @Text.decodeUtf8'@
|
||||
instance MimeUnrender PlainText Text.Text where
|
||||
fromByteString _ = left show . Text.decodeUtf8'
|
||||
|
||||
|
|
@ -1,131 +0,0 @@
|
|||
{-# 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 qualified Data.Text.Lazy as T
|
||||
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.API.ContentTypes
|
||||
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;charset=utf-8") . fst . fromJust)
|
||||
handleAcceptH (Proxy :: Proxy '[XML, JSON]) "application/json" (3 :: Int)
|
||||
`shouldSatisfy` ((== "application/json;charset=utf-8") . fst . fromJust)
|
||||
handleAcceptH (Proxy :: Proxy '[XML, JSON, HTML]) "text/html" (3 :: Int)
|
||||
`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;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;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 $
|
||||
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] T.Text
|
||||
|
||||
contentTypeApi :: Proxy ContentTypeApi
|
||||
contentTypeApi = Proxy
|
||||
|
||||
contentTypeServer :: Server ContentTypeApi
|
||||
contentTypeServer = return 5 :<|> return "hi"
|
||||
|
||||
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;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;charset=utf8" 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]]
|
||||
Loading…
Reference in New Issue
Block a user