Cookies: equal vs. equiv

http-client/ChangeLog.md

@@ -1,5 +1,9 @@
 # Changelog for http-client
 
+## 0.7.0
+
+* Remove Eq instances for Cookie, CookieJar, Response, Ord instance for Cookie [#435](https://github.com/snoyberg/http-client/pull/435)
+
 ## 0.6.4.1
 
 * Win32 2.8 support [#430](https://github.com/snoyberg/http-client/pull/430)

http-client/Network/HTTP/Client.hs

@@ -192,7 +192,12 @@ module Network.HTTP.Client
     , HttpException (..)
     , HttpExceptionContent (..)
     , Cookie (..)
+    , equalCookie
+    , equivCookie
+    , compareCookies
     , CookieJar
+    , equalCookieJar
+    , equivCookieJar
     , Proxy (..)
     , withConnection
       -- * Cookies
@@ -211,7 +216,6 @@ import Network.HTTP.Client.Types
 import Data.IORef (newIORef, writeIORef, readIORef, modifyIORef)
 import qualified Data.ByteString.Lazy as L
 import Data.Foldable (Foldable)
-import Data.Monoid
 import Data.Traversable (Traversable)
 import Network.HTTP.Types (statusCode)
 import GHC.Generics (Generic)

http-client/Network/HTTP/Client/Cookies.hs

@@ -100,7 +100,7 @@ removeExistingCookieFromCookieJar cookie cookie_jar' = (mc, CJ lc)
   where (mc, lc) = removeExistingCookieFromCookieJarHelper cookie (expose cookie_jar')
         removeExistingCookieFromCookieJarHelper _ [] = (Nothing, [])
         removeExistingCookieFromCookieJarHelper c (c' : cs)
-          | c == c' = (Just c', cs)
+          | c `equivCookie` c' = (Just c', cs)
           | otherwise = (cookie', c' : cookie_jar'')
           where (cookie', cookie_jar'') = removeExistingCookieFromCookieJarHelper c cs
 
@@ -148,7 +148,7 @@ computeCookieString request cookie_jar now is_http_api = (output_line, cookie_ja
                   | not (cookie_http_only cookie) = True
                   | otherwise = is_http_api
         matching_cookies = filter matching_cookie $ expose cookie_jar
-        output_cookies =  map (\ c -> (cookie_name c, cookie_value c)) $ L.sort matching_cookies
+        output_cookies =  map (\ c -> (cookie_name c, cookie_value c)) $ L.sortBy compareCookies matching_cookies
         output_line = toByteString $ renderCookies $ output_cookies
         folding_function cookie_jar'' cookie = case removeExistingCookieFromCookieJar cookie cookie_jar'' of
           (Just c, cookie_jar''') -> insertIntoCookieJar (c {cookie_last_access_time = now}) cookie_jar'''

http-client/Network/HTTP/Client/Types.hs

@@ -13,7 +13,12 @@ module Network.HTTP.Client.Types
     , throwHttp
     , toHttpException
     , Cookie (..)
+    , equalCookie
+    , equivCookie
+    , compareCookies
     , CookieJar (..)
+    , equalCookieJar
+    , equivCookieJar
     , Proxy (..)
     , RequestBody (..)
     , Popper
@@ -263,26 +268,64 @@ data Cookie = Cookie
 newtype CookieJar = CJ { expose :: [Cookie] }
   deriving (Read, Show, T.Typeable)
 
--- This corresponds to step 11 of the algorithm described in Section 5.3 \"Storage Model\"
-instance Eq Cookie where
-  (==) a b = name_matches && domain_matches && path_matches
-    where name_matches = cookie_name a == cookie_name b
-          domain_matches = CI.foldCase (cookie_domain a) == CI.foldCase (cookie_domain b)
-          path_matches = cookie_path a == cookie_path b
-
-instance Ord Cookie where
-  compare c1 c2
+-- | Instead of '(==)'.
+--
+-- Since there was some confusion in the history of this library about how the 'Eq' instance
+-- should work, it was removed for clarity, and replaced by 'equal' and 'equiv'.  'equal'
+-- gives you equality of all fields of the 'Cookie' record.
+--
+-- @since 0.7.0
+equalCookie :: Cookie -> Cookie -> Bool
+equalCookie a b = and
+  [ cookie_name a == cookie_name b
+  , cookie_value a == cookie_value b
+  , cookie_expiry_time a == cookie_expiry_time b
+  , cookie_domain a == cookie_domain b
+  , cookie_path a == cookie_path b
+  , cookie_creation_time a == cookie_creation_time b
+  , cookie_last_access_time a == cookie_last_access_time b
+  , cookie_persistent a == cookie_persistent b
+  , cookie_host_only a == cookie_host_only b
+  , cookie_secure_only a == cookie_secure_only b
+  , cookie_http_only a == cookie_http_only b
+  ]
+
+-- | Equality of name, domain, path only.  This corresponds to step 11 of the algorithm
+-- described in Section 5.3 \"Storage Model\".  See also: 'equal'.
+--
+-- @since 0.7.0
+equivCookie :: Cookie -> Cookie -> Bool
+equivCookie a b = name_matches && domain_matches && path_matches
+  where name_matches = cookie_name a == cookie_name b
+        domain_matches = CI.foldCase (cookie_domain a) == CI.foldCase (cookie_domain b)
+        path_matches = cookie_path a == cookie_path b
+
+-- | Instead of @instance Ord Cookie@.  See 'equalCookie', 'equivCookie'.
+--
+-- @since 0.7.0
+compareCookies :: Cookie -> Cookie -> Ordering
+compareCookies c1 c2
     | S.length (cookie_path c1) > S.length (cookie_path c2) = LT
     | S.length (cookie_path c1) < S.length (cookie_path c2) = GT
     | cookie_creation_time c1 > cookie_creation_time c2 = GT
     | otherwise = LT
 
-instance Eq CookieJar where
-  (==) cj1 cj2 = (DL.sort $ expose cj1) == (DL.sort $ expose cj2)
+-- | See 'equalCookie'.
+--
+-- @since 0.7.0
+equalCookieJar :: CookieJar -> CookieJar -> Bool
+equalCookieJar (CJ cj1) (CJ cj2) = and $ zipWith equalCookie cj1 cj2
+
+-- | See 'equalCookieJar', 'equalCookie'.
+--
+-- @since 0.7.0
+equivCookieJar :: CookieJar -> CookieJar -> Bool
+equivCookieJar cj1 cj2 = and $
+  zipWith equivCookie (DL.sortBy compareCookies $ expose cj1) (DL.sortBy compareCookies $ expose cj2)
 
 instance Semigroup CookieJar where
-  (CJ a) <> (CJ b) = CJ (DL.nub $ DL.sortBy compare' $ a <> b)
-    where compare' c1 c2 =
+  (CJ a) <> (CJ b) = CJ (DL.nubBy equivCookie $ DL.sortBy mostRecentFirst $ a <> b)
+    where mostRecentFirst c1 c2 =
             -- inverse so that recent cookies are kept by nub over older
             if cookie_creation_time c1 > cookie_creation_time c2
                 then LT
@@ -630,14 +673,18 @@ data Response body = Response
     --
     -- Since 0.1.0
     }
-    deriving (Show, Eq, T.Typeable, Functor, Data.Foldable.Foldable, Data.Traversable.Traversable)
+    deriving (Show, T.Typeable, Functor, Data.Foldable.Foldable, Data.Traversable.Traversable)
+
+-- Purposely not providing this instance.  It used to use 'equivCookieJar'
+-- semantics before 0.7.0, but should, if anything, use 'equalCookieJar'
+-- semantics.
+--
+-- instance Exception Eq
 
 newtype ResponseClose = ResponseClose { runResponseClose :: IO () }
     deriving T.Typeable
 instance Show ResponseClose where
     show _ = "ResponseClose"
-instance Eq ResponseClose where
-    _ == _ = True
 
 -- | Settings for a @Manager@. Please use the 'defaultManagerSettings' function and then modify
 -- individual settings. For more information, see <http://www.yesodweb.com/book/settings-types>.

http-client/http-client.cabal

@@ -1,5 +1,5 @@
 name:                http-client
-version:             0.6.4.1
+version:             0.7.0
 synopsis:            An HTTP client engine
 description:         Hackage documentation generation is not reliable. For up to date documentation, please see: <http://www.stackage.org/package/http-client>.
 homepage:            https://github.com/snoyberg/http-client
@@ -125,6 +125,7 @@ test-suite spec-nonet
                      , hspec
                      , monad-control
                      , bytestring
+                     , cookie
                      , text
                      , http-types
                      , blaze-builder

http-client/test-nonet/Network/HTTP/Client/CookieSpec.hs

@@ -1,9 +1,13 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Network.HTTP.Client.CookieSpec where
 
+import           Control.Monad (when)
+import           Data.Monoid
 import           Data.Time.Clock
 import           Network.HTTP.Client.Internal
 import           Test.Hspec
+import qualified Data.Time                 as DT
+import qualified Web.Cookie                as WC
 
 main :: IO ()
 main = hspec spec
@@ -14,7 +18,7 @@ spec = describe "CookieSpec" $ do
       now <- getCurrentTime
       let cookie1 = Cookie "test" "value" now "doMain.Org" "/" now now False False False False
           cookie2 = Cookie "test" "value" now "DOMAIn.ORg" "/" now now False False False False
-      cookie1 `shouldBe` cookie2
+      cookie1 `shouldSatisfy` (equivCookie cookie2)
 
     it "domainMatches - case insensitive" $ do
       domainMatches "www.org" "www.org" `shouldBe` True
@@ -24,3 +28,36 @@ spec = describe "CookieSpec" $ do
     it "domainMatches - case insensitive, partial" $ do
       domainMatches "www.org" "xxx.www.org" `shouldBe` False
       domainMatches "xxx.www.org" "WWW.ORG" `shouldBe` True
+
+    describe "equalCookie vs. equivCookie" $ do
+      let make :: IO Cookie
+          make = do
+            now <- DT.getCurrentTime
+            req <- parseRequest "http://www.example.com/path"
+            let Just cky = generateCookie (WC.parseSetCookie raw) req now True
+                raw = "somename=somevalue.v=1.k=1.d=1590419679.t=u.l=s.u=8b2734ae-9dd1-11ea-bd7f-3bcf5b8d5d2a.r=795e71b5; " <>
+                      "Path=/access; Domain=example.com; HttpOnly; Secure"
+            return cky
+
+          modifications :: [(String, Cookie -> Cookie, Bool)]
+          modifications
+              = [ ("cookie_name", \cky -> cky { cookie_name = "othername" }, True)
+                , ("cookie_value", \cky -> cky { cookie_value = "othervalue" }, False)
+                , ("cookie_expiry_time", \cky -> cky { cookie_expiry_time = DT.addUTCTime 60 $ cookie_expiry_time cky }, False)
+                , ("cookie_domain", \cky -> cky { cookie_domain = cookie_domain cky <> ".com" }, True)
+                , ("cookie_path", \cky -> cky { cookie_path = cookie_path cky <> "/sub" }, True)
+                , ("cookie_creation_time", \cky -> cky { cookie_creation_time = DT.addUTCTime 60 $ cookie_creation_time cky }, False)
+                , ("cookie_last_access_time", \cky -> cky { cookie_last_access_time = DT.addUTCTime 60 $ cookie_last_access_time cky }, False)
+                , ("cookie_persistent", \cky -> cky { cookie_persistent = not $ cookie_persistent cky }, False)
+                , ("cookie_host_only", \cky -> cky { cookie_host_only = not $ cookie_host_only cky }, False)
+                , ("cookie_secure_only", \cky -> cky { cookie_secure_only = not $ cookie_secure_only cky }, False)
+                , ("cookie_http_only", \cky -> cky { cookie_http_only = not $ cookie_http_only cky }, False)
+                ]
+
+          check :: (String, Cookie -> Cookie, Bool) -> Spec
+          check (msg, f, countsForEquiv) = it msg $ do
+            cky <- make
+            cky `equalCookie` f cky `shouldBe` False
+            when countsForEquiv $ cky `equivCookie` f cky `shouldBe` False
+
+      check `mapM_` modifications

http-conduit/http-conduit.cabal

@@ -30,7 +30,7 @@ library
                  , conduit               >= 1.2
                  , conduit-extra         >= 1.1
                  , http-types            >= 0.7
-                 , http-client           >= 0.5.13  && < 0.7
+                 , http-client           >= 0.5.13  && < 0.8
                  , http-client-tls       >= 0.3     && < 0.4
                  , mtl
                  , unliftio-core

http-conduit/test/CookieTest.hs

@@ -1,3 +1,5 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
+
 module CookieTest (cookieTest) where
 
 import Prelude hiding (exp)
@@ -13,6 +15,25 @@ import Data.Time.Calendar
 import qualified Data.CaseInsensitive as CI
 import Web.Cookie
 
+-- We use these Eq instances here because they make sense and may be added to the library in
+-- the future.  We do not add them now because they would silently break the old Eq behavior,
+-- which was `equivCookie`.
+instance Eq Cookie where
+  (==) = equalCookie
+
+instance Eq CookieJar where
+  (==) = equalCookieJar
+
+instance Eq body => Eq (Response body) where
+  resp == resp' = and
+    [ responseStatus resp == responseStatus resp'
+    , responseVersion resp == responseVersion resp'
+    , responseHeaders resp == responseHeaders resp'
+    , responseBody resp == responseBody resp'
+    , responseCookieJar resp `equivCookieJar` responseCookieJar resp'  -- !
+    -- , responseClose  -- !
+    ]
+
 default_request :: HC.Request
 default_request = HC.parseRequest_ "http://www.google.com/"
 
@@ -127,8 +148,8 @@ testCookieEqualitySuccess = assertEqual "The same cookies should be equal"
   where cookie = default_cookie
 
 testCookieEqualityResiliance :: IO ()
-testCookieEqualityResiliance = assertEqual "Cookies should still be equal if extra options are changed"
-  (default_cookie {cookie_persistent = True}) (default_cookie {cookie_host_only = True})
+testCookieEqualityResiliance = assertBool "Cookies should still be equal if extra options are changed" $
+  (default_cookie {cookie_persistent = True}) `equivCookie` (default_cookie {cookie_host_only = True})
 
 testDomainChangesEquality :: IO ()
 testDomainChangesEquality = assertBool "Changing the domain should make cookies not equal" $
@@ -228,8 +249,9 @@ testComputeCookieStringHttpOnly = assertEqual "http-only flag filters properly"
   where cookie_jar = createCookieJar [default_cookie {cookie_http_only = True}]
 
 testComputeCookieStringSort :: IO ()
-testComputeCookieStringSort = assertEqual "Sorting works correctly"
-  (fromString "c1=v1;c3=v3;c4=v4;c2=v2", cookie_jar_out) format_output
+testComputeCookieStringSort = do
+  assertEqual "Sorting works correctly (computed string)" (fst format_output) (fromString "c1=v1;c3=v3;c4=v4;c2=v2")
+  assertBool "Sorting works correctly (remaining jar)" $ (snd format_output) `equivCookieJar` cookie_jar_out
   where now = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 11)
         cookie_jar = createCookieJar [ default_cookie { cookie_name = fromString "c1"
                                                       , cookie_value = fromString "v1"
@@ -289,27 +311,27 @@ testInsertCookiesIntoRequestWorks = assertEqual "Inserting cookies works"
                                                       fromString "otherkey=otherval")]}
 
 testReceiveSetCookie :: IO ()
-testReceiveSetCookie = assertEqual "Receiving a Set-Cookie"
-  (createCookieJar [default_cookie]) (receiveSetCookie default_set_cookie default_request default_time True $ createCookieJar [])
+testReceiveSetCookie = assertBool "Receiving a Set-Cookie" $
+  (createCookieJar [default_cookie]) `equivCookieJar` (receiveSetCookie default_set_cookie default_request default_time True $ createCookieJar [])
 
 testReceiveSetCookieTrailingDot :: IO ()
 testReceiveSetCookieTrailingDot = assertEqual "Receiving a Set-Cookie with a trailing domain dot"
   (createCookieJar []) (receiveSetCookie set_cookie default_request default_time True $ createCookieJar [])
   where set_cookie = default_set_cookie {setCookieDomain = Just $ fromString "www.google.com."}
 
 testReceiveSetCookieLeadingDot :: IO ()
-testReceiveSetCookieLeadingDot = assertEqual "Receiving a Set-Cookie with a leading domain dot"
-  (createCookieJar [default_cookie]) (receiveSetCookie set_cookie default_request default_time True $ createCookieJar [])
+testReceiveSetCookieLeadingDot = assertBool "Receiving a Set-Cookie with a leading domain dot" $
+  (createCookieJar [default_cookie]) `equivCookieJar` (receiveSetCookie set_cookie default_request default_time True $ createCookieJar [])
   where set_cookie = default_set_cookie {setCookieDomain = Just $ fromString ".www.google.com"}
 
 testReceiveSetCookieNoDomain :: IO ()
-testReceiveSetCookieNoDomain = assertEqual "Receiving cookie without domain"
-  (createCookieJar [default_cookie]) (receiveSetCookie set_cookie default_request default_time True $ createCookieJar [])
+testReceiveSetCookieNoDomain = assertBool "Receiving cookie without domain" $
+  (createCookieJar [default_cookie]) `equivCookieJar` (receiveSetCookie set_cookie default_request default_time True $ createCookieJar [])
   where set_cookie = default_set_cookie {setCookieDomain = Nothing}
 
 testReceiveSetCookieEmptyDomain :: IO ()
-testReceiveSetCookieEmptyDomain = assertEqual "Receiving cookie with empty domain"
-  (createCookieJar [default_cookie]) (receiveSetCookie set_cookie default_request default_time True $ createCookieJar [])
+testReceiveSetCookieEmptyDomain = assertBool "Receiving cookie with empty domain" $
+  (createCookieJar [default_cookie]) `equivCookieJar` (receiveSetCookie set_cookie default_request default_time True $ createCookieJar [])
   where set_cookie = default_set_cookie {setCookieDomain = Just BS.empty}
 
 -- Can't test public suffixes until that module is written