Fix multiple headers with the same name (#1666)

Author: dgaw

changelog.d/1665

@@ -0,0 +1,9 @@
+synopsis: Fix the handling of multiple headers with the same name.
+prs: #1666
+
+description: {
+
+servant-client no longer concatenates the values of response headers with the same name.
+This fixes an issue with parsing multiple `Set-Cookie` headers.
+
+}

servant-client/test/Servant/ClientTestUtils.hs

@@ -107,6 +107,7 @@ carol :: Person
 carol = Person "Carol" 17
 
 type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String]
+type TestSetCookieHeaders = '[Header "Set-Cookie" String, Header "Set-Cookie" String]
 
 data RecordRoutes mode = RecordRoutes
   { version :: mode :- "version" :> Get '[JSON] Int
@@ -151,6 +152,7 @@ type Api =
             Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])])
   :<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool)
   :<|> "uverb-headers" :> UVerb 'GET '[JSON] '[ WithStatus 200 (Headers TestHeaders Bool), WithStatus 204 String ]
+  :<|> "set-cookie-headers" :> Get '[JSON] (Headers TestSetCookieHeaders Bool)
   :<|> "deleteContentType" :> DeleteNoContent
   :<|> "redirectWithCookie" :> Raw
   :<|> "empty" :> EmptyAPI
@@ -184,6 +186,7 @@ getMultiple     :: String -> Maybe Int -> Bool -> [(String, [Rational])]
   -> ClientM (String, Maybe Int, Bool, [(String, [Rational])])
 getRespHeaders  :: ClientM (Headers TestHeaders Bool)
 getUVerbRespHeaders  :: ClientM (Union '[ WithStatus 200 (Headers TestHeaders Bool), WithStatus 204 String ])
+getSetCookieHeaders  :: ClientM (Headers TestSetCookieHeaders Bool)
 getDeleteContentType :: ClientM NoContent
 getRedirectWithCookie :: HTTP.Method -> ClientM Response
 uverbGetSuccessOrRedirect :: Bool
@@ -210,6 +213,7 @@ getRoot
   :<|> getMultiple
   :<|> getRespHeaders
   :<|> getUVerbRespHeaders
+  :<|> getSetCookieHeaders
   :<|> getDeleteContentType
   :<|> getRedirectWithCookie
   :<|> EmptyClient
@@ -247,6 +251,7 @@ server = serve api (
   :<|> (\ a b c d -> return (a, b, c, d))
   :<|> (return $ addHeader 1729 $ addHeader "eg2" True)
   :<|> (pure . Z . I . WithStatus $ addHeader 1729 $ addHeader "eg2" True)
+  :<|> (return $ addHeader "cookie1" $ addHeader "cookie2" True)
   :<|> return NoContent
   :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.found302 [("Location", "testlocation"), ("Set-Cookie", "testcookie=test")] "")
   :<|> emptyServer

servant-client/test/Servant/SuccessSpec.hs

@@ -150,6 +150,12 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
             -> getHeaders val' `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]
           Nothing -> assertFailure "unexpected alternative of union"
 
+    it "Returns multiple Set-Cookie headers appropriately" $ \(_, baseUrl) -> do
+      res <- runClient getSetCookieHeaders baseUrl
+      case res of
+        Left e -> assertFailure $ show e
+        Right val -> getHeaders val `shouldBe` [("Set-Cookie", "cookie1"), ("Set-Cookie", "cookie2")]
+
     it "Stores Cookie in CookieJar after a redirect" $ \(_, baseUrl) -> do
       mgr <- C.newManager C.defaultManagerSettings
       cj <- atomically . newTVar $ C.createCookieJar []

servant/src/Servant/API/ResponseHeaders.hs

@@ -39,6 +39,7 @@ import           Control.DeepSeq
 import           Data.ByteString.Char8     as BS
                  (ByteString, init, pack, unlines)
 import qualified Data.CaseInsensitive      as CI
+import qualified Data.List                 as L
 import           Data.Proxy
 import           Data.Typeable
                  (Typeable)
@@ -97,24 +98,21 @@ type family HeaderValMap (f :: * -> *) (xs :: [*]) where
 
 class BuildHeadersTo hs where
     buildHeadersTo :: [HTTP.Header] -> HList hs
-    -- ^ Note: if there are multiple occurrences of a header in the argument,
-    -- the values are interspersed with commas before deserialization (see
-    -- <http://www.w3.org/Protocols/rfc2616/rfc2616-sec4.html#sec4.2 RFC2616 Sec 4.2>)
 
 instance {-# OVERLAPPING #-} BuildHeadersTo '[] where
     buildHeadersTo _ = HNil
 
+-- The current implementation does not manipulate HTTP header field lines in any way,
+-- like merging field lines with the same field name in a single line.
 instance {-# OVERLAPPABLE #-} ( FromHttpApiData v, BuildHeadersTo xs, KnownSymbol h )
          => BuildHeadersTo (Header h v ': xs) where
-    buildHeadersTo headers =
-      let wantedHeader = CI.mk . pack $ symbolVal (Proxy :: Proxy h)
-          matching = snd <$> filter (\(h, _) -> h == wantedHeader) headers
-      in case matching of
-        [] -> MissingHeader `HCons` buildHeadersTo headers
-        xs -> case parseHeader (BS.init $ BS.unlines xs) of
-          Left _err -> UndecodableHeader (BS.init $ BS.unlines xs)
-             `HCons` buildHeadersTo headers
-          Right h   -> Header h `HCons` buildHeadersTo headers
+    buildHeadersTo headers = case L.find wantedHeader headers of
+      Nothing -> MissingHeader `HCons` buildHeadersTo headers
+      Just header@(_, val) -> case parseHeader val of
+        Left _err -> UndecodableHeader val `HCons` buildHeadersTo (L.delete header headers)
+        Right h   -> Header h `HCons` buildHeadersTo (L.delete header headers)
+      where wantedHeader (h, _) = h == wantedHeaderName
+            wantedHeaderName = CI.mk . pack $ symbolVal (Proxy :: Proxy h)
 
 -- * Getting headers