diff --git a/src/Servant/API/ContentTypes.hs b/src/Servant/API/ContentTypes.hs index 3ae20b71..734ec17c 100644 --- a/src/Servant/API/ContentTypes.hs +++ b/src/Servant/API/ContentTypes.hs @@ -6,6 +6,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} @@ -83,6 +84,7 @@ import qualified Data.Text.Lazy.Encoding as TextL import Data.Typeable import GHC.Exts (Constraint) import qualified Network.HTTP.Media as M +import Network.HTTP.Types.Header import Network.URI (escapeURIString, isUnreserved, unEscapeString) @@ -147,13 +149,13 @@ newtype AcceptHeader = AcceptHeader BS.ByteString -- > type MyAPI = "path" :> Get '[MyContentType] Int -- class Accept ctype => MimeRender ctype a where - toByteString :: Proxy ctype -> a -> ByteString + toByteString :: Proxy ctype -> a -> (ResponseHeaders, ByteString) class AllCTRender (list :: [*]) a where -- If the Accept header can be matched, returns (Just) a tuple of the -- Content-Type and response (serialization of @a@ into the appropriate -- mimetype). - handleAcceptH :: Proxy list -> AcceptHeader -> a -> Maybe (ByteString, ByteString) + handleAcceptH :: Proxy list -> AcceptHeader -> a -> Maybe (ByteString, (ResponseHeaders, ByteString)) instance ( AllMimeRender ctyps a, IsNonEmpty ctyps ) => AllCTRender ctyps a where @@ -188,18 +190,19 @@ instance ( AllMimeRender ctyps a, IsNonEmpty ctyps -- >>> type MyAPI = "path" :> ReqBody '[MyContentType] Int :> Get '[JSON] Int -- class Accept ctype => MimeUnrender ctype a where - fromByteString :: Proxy ctype -> ByteString -> Either String a + fromByteString :: Proxy ctype -> ResponseHeaders -> ByteString -> Either String a class (IsNonEmpty list) => AllCTUnrender (list :: [*]) a where handleCTypeH :: Proxy list + -> ResponseHeaders -- Headers -> ByteString -- Content-Type header -> ByteString -- Request body -> Maybe (Either String a) instance ( AllMimeUnrender ctyps a, IsNonEmpty ctyps ) => AllCTUnrender ctyps a where - handleCTypeH _ ctypeH body = M.mapContentMedia lkup (cs ctypeH) - where lkup = allMimeUnrender (Proxy :: Proxy ctyps) body + handleCTypeH _ hs ctypeH body = M.mapContentMedia lkup (cs ctypeH) + where lkup = allMimeUnrender (Proxy :: Proxy ctyps) hs body -------------------------------------------------------------------------- -- * Utils (Internal) @@ -211,7 +214,7 @@ instance ( AllMimeUnrender ctyps a, IsNonEmpty ctyps class AllMimeRender (list :: [*]) a where allMimeRender :: Proxy list -> a -- value to serialize - -> [(M.MediaType, ByteString)] -- content-types/response pairs + -> [(M.MediaType, (ResponseHeaders, ByteString))] -- content-types/response pairs instance ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where allMimeRender _ a = [(contentType pctyp, toByteString pctyp a)] @@ -234,17 +237,18 @@ instance AllMimeRender '[] a where -------------------------------------------------------------------------- class AllMimeUnrender (list :: [*]) a where allMimeUnrender :: Proxy list + -> ResponseHeaders -> ByteString -> [(M.MediaType, Either String a)] instance AllMimeUnrender '[] a where - allMimeUnrender _ _ = [] + allMimeUnrender _ _ _ = [] instance ( MimeUnrender ctyp a , AllMimeUnrender ctyps a ) => AllMimeUnrender (ctyp ': ctyps) a where - allMimeUnrender _ val = (contentType pctyp, fromByteString pctyp val) - :(allMimeUnrender pctyps val) + allMimeUnrender _ hs val = (contentType pctyp, fromByteString pctyp hs val) + :(allMimeUnrender pctyps hs val) where pctyp = Proxy :: Proxy ctyp pctyps = Proxy :: Proxy ctyps @@ -257,29 +261,29 @@ type family IsNonEmpty (list :: [*]) :: Constraint where -- | `encode` instance ToJSON a => MimeRender JSON a where - toByteString _ = encode + toByteString _ = ([],) . encode -- | @encodeFormUrlEncoded . toFormUrlEncoded@ -- Note that the @fromByteString p (toByteString p x) == Right x@ law only -- holds if every element of x is non-null (i.e., not @("", "")@) instance ToFormUrlEncoded a => MimeRender FormUrlEncoded a where - toByteString _ = encodeFormUrlEncoded . toFormUrlEncoded + toByteString _ = ([],) . encodeFormUrlEncoded . toFormUrlEncoded -- | `TextL.encodeUtf8` instance MimeRender PlainText TextL.Text where - toByteString _ = TextL.encodeUtf8 + toByteString _ = ([],) . TextL.encodeUtf8 -- | @fromStrict . TextS.encodeUtf8@ instance MimeRender PlainText TextS.Text where - toByteString _ = fromStrict . TextS.encodeUtf8 + toByteString _ = ([],) . fromStrict . TextS.encodeUtf8 -- | @id@ instance MimeRender OctetStream ByteString where - toByteString _ = id + toByteString _ = ([],) -- | `fromStrict` instance MimeRender OctetStream BS.ByteString where - toByteString _ = fromStrict + toByteString _ = ([],) . fromStrict -------------------------------------------------------------------------- @@ -294,29 +298,29 @@ eitherDecodeLenient input = do -- | `eitherDecode` instance FromJSON a => MimeUnrender JSON a where - fromByteString _ = eitherDecodeLenient + fromByteString _ _ = eitherDecodeLenient -- | @decodeFormUrlEncoded >=> fromFormUrlEncoded@ -- Note that the @fromByteString p (toByteString p x) == Right x@ law only -- holds if every element of x is non-null (i.e., not @("", "")@) instance FromFormUrlEncoded a => MimeUnrender FormUrlEncoded a where - fromByteString _ = decodeFormUrlEncoded >=> fromFormUrlEncoded + fromByteString _ _ = decodeFormUrlEncoded >=> fromFormUrlEncoded -- | @left show . TextL.decodeUtf8'@ instance MimeUnrender PlainText TextL.Text where - fromByteString _ = left show . TextL.decodeUtf8' + fromByteString _ _ = left show . TextL.decodeUtf8' -- | @left show . TextS.decodeUtf8' . toStrict@ instance MimeUnrender PlainText TextS.Text where - fromByteString _ = left show . TextS.decodeUtf8' . toStrict + fromByteString _ _ = left show . TextS.decodeUtf8' . toStrict -- | @Right . id@ instance MimeUnrender OctetStream ByteString where - fromByteString _ = Right . id + fromByteString _ _ = Right -- | @Right . toStrict@ instance MimeUnrender OctetStream BS.ByteString where - fromByteString _ = Right . toStrict + fromByteString _ _ = Right . toStrict -------------------------------------------------------------------------- diff --git a/test/Servant/API/ContentTypesSpec.hs b/test/Servant/API/ContentTypesSpec.hs index 2a4a071d..02bcfb0c 100644 --- a/test/Servant/API/ContentTypesSpec.hs +++ b/test/Servant/API/ContentTypesSpec.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Servant.API.ContentTypesSpec where @@ -36,11 +37,11 @@ spec = describe "Servant.API.ContentTypes" $ do it "has fromByteString reverse toByteString for valid top-level json ([Int]) " $ do let p = Proxy :: Proxy JSON - property $ \x -> fromByteString p (toByteString p x) == Right (x::[Int]) + property $ \x -> uncurry (fromByteString p) (toByteString p x) == Right (x::[Int]) it "has fromByteString reverse toByteString for valid top-level json " $ do let p = Proxy :: Proxy JSON - property $ \x -> fromByteString p (toByteString p x) == Right (x::SomeData) + property $ \x -> uncurry (fromByteString p) (toByteString p x) == Right (x::SomeData) describe "The FormUrlEncoded Content-Type type" $ do @@ -50,39 +51,39 @@ spec = describe "Servant.API.ContentTypes" $ do it "has fromByteString reverse toByteString" $ do let p = Proxy :: Proxy FormUrlEncoded property $ \x -> all isNonNull x - ==> fromByteString p (toByteString p x) == Right (x::[(TextS.Text,TextS.Text)]) + ==> uncurry (fromByteString p) (toByteString p x) == Right (x::[(TextS.Text,TextS.Text)]) it "has fromByteString reverse exportParams (Network.URL)" $ do let p = Proxy :: Proxy FormUrlEncoded property $ \x -> all isNonNull x - ==> (fromByteString p . cs . exportParams . map (cs *** cs) $ x) == Right (x::[(TextS.Text,TextS.Text)]) + ==> (fromByteString p [] . cs . exportParams . map (cs *** cs) $ x) == Right (x::[(TextS.Text,TextS.Text)]) it "has importParams (Network.URL) reverse toByteString" $ do let p = Proxy :: Proxy FormUrlEncoded property $ \x -> all isNonNull x - ==> (fmap (map (cs *** cs)) . importParams . cs . toByteString p $ x) == Just (x::[(TextS.Text,TextS.Text)]) + ==> (fmap (map (cs *** cs)) . importParams . cs . snd . toByteString p $ x) == Just (x::[(TextS.Text,TextS.Text)]) describe "The PlainText Content-Type type" $ do it "has fromByteString reverse toByteString (lazy Text)" $ do let p = Proxy :: Proxy PlainText - property $ \x -> fromByteString p (toByteString p x) == Right (x::TextL.Text) + property $ \x -> uncurry (fromByteString p) (toByteString p x) == Right (x::TextL.Text) it "has fromByteString reverse toByteString (strict Text)" $ do let p = Proxy :: Proxy PlainText - property $ \x -> fromByteString p (toByteString p x) == Right (x::TextS.Text) + property $ \x -> uncurry (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 + 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 + property $ \x -> toByteString p x == ([], BSL.fromStrict x) + && fromByteString p [] (BSL.fromStrict x) == Right x describe "handleAcceptH" $ do @@ -110,7 +111,7 @@ spec = describe "Servant.API.ContentTypes" $ do it "returns the appropriately serialized representation" $ do property $ \x -> handleAcceptH (Proxy :: Proxy '[JSON]) "*/*" (x :: SomeData) - == Just ("application/json", encode x) + == Just ("application/json", ([], encode x)) it "respects the Accept spec ordering" $ do let highest a b c = maximumBy (compare `on` snd) @@ -128,17 +129,17 @@ spec = describe "Servant.API.ContentTypes" $ do describe "handleCTypeH" $ do it "returns Nothing if the 'Content-Type' header doesn't match" $ do - handleCTypeH (Proxy :: Proxy '[JSON]) "text/plain" "𝓽𝓱𝓮 𝓽𝓲𝓶𝓮 𝓱𝓪𝓼 𝓬𝓸𝓶𝓮, 𝓽𝓱𝓮 𝔀𝓪𝓵𝓻𝓾𝓼 𝓼𝓪𝓲𝓭 " + handleCTypeH (Proxy :: Proxy '[JSON]) [] "text/plain" "𝓽𝓱𝓮 𝓽𝓲𝓶𝓮 𝓱𝓪𝓼 𝓬𝓸𝓶𝓮, 𝓽𝓱𝓮 𝔀𝓪𝓵𝓻𝓾𝓼 𝓼𝓪𝓲𝓭 " `shouldBe` (Nothing :: Maybe (Either String Value)) context "the 'Content-Type' header matches" $ do it "returns Just if the parameter matches" $ do - handleCTypeH (Proxy :: Proxy '[JSON]) "application/json" + handleCTypeH (Proxy :: Proxy '[JSON]) [] "application/json" "𝕥𝕠 𝕥𝕒𝕝𝕜 𝕠𝕗 𝕞𝕒𝕟𝕪 𝕥𝕙𝕚𝕟𝕘𝕤 " `shouldSatisfy` (isJust :: Maybe (Either String Value) -> Bool) it "returns Just if there is no parameter" $ do - handleCTypeH (Proxy :: Proxy '[JSON]) "application/json" + handleCTypeH (Proxy :: Proxy '[JSON]) [] "application/json" "𝕥𝕠 𝕥𝕒𝕝𝕜 𝕠𝕗 𝕞𝕒𝕟𝕪 𝕥𝕙𝕚𝕟𝕘𝕤 " `shouldSatisfy` (isJust :: Maybe (Either String Value) -> Bool) @@ -146,13 +147,13 @@ spec = describe "Servant.API.ContentTypes" $ do let isJustLeft :: Maybe (Either String Value) -> Bool isJustLeft (Just (Left _)) = True isJustLeft _ = False - handleCTypeH (Proxy :: Proxy '[JSON]) "application/json" + handleCTypeH (Proxy :: Proxy '[JSON]) [] "application/json" "𝕺𝖋 𝖘𝖍𝖔𝖊𝖘--𝖆𝖓𝖉 𝖘𝖍𝖎𝖕𝖘--𝖆𝖓𝖉 𝖘𝖊𝖆𝖑𝖎𝖓𝖌-𝖜𝖆𝖝-- " `shouldSatisfy` isJustLeft it "returns Just (Right val) if the decoding succeeds" $ do let val = SomeData "Of cabbages--and kings" 12 - handleCTypeH (Proxy :: Proxy '[JSON]) "application/json" + handleCTypeH (Proxy :: Proxy '[JSON]) [] "application/json" (encode val) `shouldBe` Just (Right val) @@ -182,13 +183,13 @@ instance Arbitrary ZeroToOne where arbitrary = ZeroToOne <$> elements [ x / 10 | x <- [1..10]] instance MimeRender OctetStream Int where - toByteString _ = cs . show + toByteString _ = ([],) . cs . show instance MimeRender PlainText Int where - toByteString _ = cs . show + toByteString _ = ([],) . cs . show instance MimeRender PlainText ByteString where - toByteString _ = cs + toByteString _ = ([],) . cs instance ToJSON ByteString where toJSON x = object [ "val" .= x ]