Preliminary work to support headers in responses

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)
+    handleCTypeH _ hs ctypeH body = M.mapContentMedia lkup (cs ctypeH)
-      where lkup = allMimeUnrender (Proxy :: Proxy ctyps) body
+      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 _ hs val = (contentType pctyp, fromByteString pctyp hs val)
-                           :(allMimeUnrender pctyps 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
 
 
 --------------------------------------------------------------------------

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)
+            property $ \x -> toByteString p x == ([], x :: BSL.ByteString)
-                && fromByteString p x == Right x
+                && 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)
+            property $ \x -> toByteString p x == ([], BSL.fromStrict x)
-                && fromByteString p (BSL.fromStrict x) == Right 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 ]