Remove ContentTypes.hs

This commit is contained in:
Julian K. Arni 2015-02-21 18:05:31 +01:00
parent e9f3341b9e
commit 0789682cf8
5 changed files with 0 additions and 187 deletions

View file

@ -31,7 +31,6 @@ library
exposed-modules: exposed-modules:
Servant Servant
Servant.Server Servant.Server
Servant.Server.ContentTypes
Servant.Server.Internal Servant.Server.Internal
Servant.Utils.StaticFiles Servant.Utils.StaticFiles
build-depends: build-depends:
@ -40,7 +39,6 @@ library
, attoparsec >= 0.12 && < 0.13 , attoparsec >= 0.12 && < 0.13
, bytestring >= 0.10 && < 0.11 , bytestring >= 0.10 && < 0.11
, either >= 4.3 && < 4.4 , either >= 4.3 && < 4.4
, http-media >= 0.4 && < 0.5
, http-types >= 0.8 && < 0.9 , http-types >= 0.8 && < 0.9
, network-uri >= 2.6 && < 2.7 , network-uri >= 2.6 && < 2.7
, safe >= 0.3 && < 0.4 , safe >= 0.3 && < 0.4

View file

@ -8,7 +8,6 @@ module Servant (
-- | Using your types in request paths and query string parameters -- | Using your types in request paths and query string parameters
module Servant.Common.Text, module Servant.Common.Text,
-- | Utilities on top of the servant core -- | Utilities on top of the servant core
module Servant.QQ,
module Servant.Utils.Links, module Servant.Utils.Links,
module Servant.Utils.StaticFiles, module Servant.Utils.StaticFiles,
-- | Useful re-exports -- | Useful re-exports
@ -19,6 +18,5 @@ import Data.Proxy
import Servant.API import Servant.API
import Servant.Common.Text import Servant.Common.Text
import Servant.Server import Servant.Server
import Servant.QQ
import Servant.Utils.Links import Servant.Utils.Links
import Servant.Utils.StaticFiles import Servant.Utils.StaticFiles

View file

@ -16,7 +16,6 @@ import Data.Proxy (Proxy)
import Network.Wai (Application) import Network.Wai (Application)
import Servant.Server.Internal import Servant.Server.Internal
import Servant.Server.ContentTypes ()
-- * Implementing Servers -- * Implementing Servers

View file

@ -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'

View file

@ -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]]