diff --git a/servant.cabal b/servant.cabal index fbb89db5..01f74aff 100644 --- a/servant.cabal +++ b/servant.cabal @@ -87,6 +87,7 @@ test-suite spec build-depends: base == 4.* , aeson + , bytestring , hspec == 2.* , QuickCheck , parsec diff --git a/src/Servant/API/ContentTypes.hs b/src/Servant/API/ContentTypes.hs index b2d5dc1d..8ac5fcca 100644 --- a/src/Servant/API/ContentTypes.hs +++ b/src/Servant/API/ContentTypes.hs @@ -104,7 +104,7 @@ instance ( AllMimeRender ctyps a, IsNonEmpty ctyps -- > instance Accept MyContentType where -- > contentType _ = "example" // "prs.me.mine" /: ("charset", "utf-8") -- > --- > instance Show a => MimeRender MyContentType where +-- > instance Show a => MimeUnrender MyContentType where -- > fromByteString _ bs = MyContentType $ unpack bs -- > -- > type MyAPI = "path" :> ReqBody '[MyContentType] :> Get '[JSON] Int @@ -191,6 +191,11 @@ instance MimeRender PlainText TextS.Text where instance MimeRender OctetStream ByteString where toByteString _ = id +-- | `toStrict` +instance MimeRender OctetStream BS.ByteString where + toByteString _ = fromStrict + + -------------------------------------------------------------------------- -- * MimeUnrender Instances @@ -209,3 +214,7 @@ instance MimeUnrender PlainText TextS.Text where -- | `Right . id` instance MimeUnrender OctetStream ByteString where fromByteString _ = Right . id + +-- | `Right . toStrict` +instance MimeUnrender OctetStream BS.ByteString where + fromByteString _ = Right . toStrict diff --git a/test/Servant/API/ContentTypesSpec.hs b/test/Servant/API/ContentTypesSpec.hs index 6ce225cf..a99f95fa 100644 --- a/test/Servant/API/ContentTypesSpec.hs +++ b/test/Servant/API/ContentTypesSpec.hs @@ -1,10 +1,21 @@ -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Servant.API.ContentTypesSpec where import Control.Applicative import Data.Aeson +import Data.Function (on) import Data.Proxy + +import Data.ByteString.Char8 +import qualified Data.ByteString.Lazy as BSL +import Data.List (maximumBy) +import Data.Maybe (fromJust, isJust) +import Data.String (IsString (..)) +import Data.String.Conversions (cs) import qualified Data.Text as TextS import qualified Data.Text.Lazy as TextL import GHC.Generics @@ -36,12 +47,66 @@ spec = describe "Servant.API.ContentTypes" $ do let p = Proxy :: Proxy PlainText property $ \x -> fromByteString p (toByteString p x) == Right (x::TextS.Text) + describe "The OctetStream Content-Type type" $ do + + it "is id (Lazy ByteString)" $ do + let p = Proxy :: Proxy OctetStream + property $ \x -> toByteString p x == (x :: BSL.ByteString) + && fromByteString p x == Right x + + it "is fromStrict/toStrict (Strict ByteString)" $ do + let p = Proxy :: Proxy OctetStream + property $ \x -> toByteString p x == BSL.fromStrict (x :: ByteString) + && fromByteString p (BSL.fromStrict x) == Right x + + describe "handleAcceptH" $ do + + it "returns Just if the 'Accept' header matches" $ do + handleAcceptH (Proxy :: Proxy '[JSON]) "*/*" (3 :: Int) + `shouldSatisfy` isJust + handleAcceptH (Proxy :: Proxy '[PlainText, JSON]) "application/json" (3 :: Int) + `shouldSatisfy` isJust + handleAcceptH (Proxy :: Proxy '[PlainText, JSON, OctetStream]) + "application/octet-stream" ("content" :: ByteString) + `shouldSatisfy` isJust + + it "returns 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 '[PlainText, JSON]) "application/json" (3 :: Int) + `shouldSatisfy` ((== "application/json;charset=utf-8") . fst . fromJust) + handleAcceptH (Proxy :: Proxy '[PlainText, JSON, OctetStream]) + "application/octet-stream" ("content" :: ByteString) + `shouldSatisfy` ((== "application/octet-stream") . fst . fromJust) + + it "returns the appropriately serialized representation" $ do + property $ \x -> handleAcceptH (Proxy :: Proxy '[JSON]) "*/*" (x :: SomeData) + == 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) + [ ("application/octet-stream", a) + , ("application/json;charset=utf-8", b) + , ("text/plain;charset=utf-8", c) + ] + acceptH a b c = addToAccept (Proxy :: Proxy OctetStream) a $ + addToAccept (Proxy :: Proxy JSON) b $ + addToAccept (Proxy :: Proxy PlainText ) c "" + val a b c i = handleAcceptH (Proxy :: Proxy '[OctetStream, JSON, PlainText]) + (acceptH a b c) (i :: Int) data SomeData = SomeData { record1 :: String, record2 :: Int } deriving (Generic, Eq, Show) +newtype ZeroToOne = ZeroToOne Float + deriving (Eq, Show, Ord) + instance FromJSON SomeData + instance ToJSON SomeData + instance Arbitrary SomeData where arbitrary = SomeData <$> arbitrary <*> arbitrary @@ -50,3 +115,33 @@ instance Arbitrary TextL.Text where instance Arbitrary TextS.Text where arbitrary = TextS.pack <$> arbitrary + +instance Arbitrary ZeroToOne where + arbitrary = ZeroToOne <$> elements [ x / 10 | x <- [1..10]] + +instance MimeRender OctetStream Int where + toByteString _ = cs . show + +instance MimeRender PlainText Int where + toByteString _ = cs . show + +instance MimeRender PlainText ByteString where + toByteString _ = cs + +instance ToJSON ByteString where + toJSON x = object [ "val" .= x ] + +instance IsString AcceptHeader where + fromString = AcceptHeader . fromString + +instance Arbitrary BSL.ByteString where + arbitrary = cs <$> (arbitrary :: Gen String) + +instance Arbitrary ByteString where + arbitrary = cs <$> (arbitrary :: Gen String) + +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