Remove ContentTypes.hs
This commit is contained in:
Julian K. Arni
parent
e9f3341b9e
commit
0789682cf8
5 changed files with 0 additions and 187 deletions
|
|
@ -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
|
||||||
|
|
|
||||||
|
|
@ -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
|
||||||
|
|
|
||||||
|
|
@ -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
|
||||||
|
|
|
||||||
|
|
@ -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 a new issue