More content type tests

servant.cabal

@@ -87,6 +87,7 @@ test-suite spec
   build-depends:
       base == 4.*
     , aeson
+    , bytestring
     , hspec == 2.*
     , QuickCheck
     , parsec

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

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