Cookies: equal vs. equiv

http-client/Network/HTTP/Client.hs

@@ -192,7 +192,12 @@ module Network.HTTP.Client
     , HttpException (..)
     , HttpExceptionContent (..)
     , Cookie (..)
+    , equal
+    , equiv
+    , compareCookies
     , CookieJar
+    , equalCookieJar
+    , equivCookieJar
     , Proxy (..)
     , withConnection
       -- * Cookies

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 `equiv` 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 (..)
+    , equal
+    , equiv
+    , compareCookies
     , CookieJar (..)
+    , equalCookieJar
+    , equivCookieJar
     , Proxy (..)
     , RequestBody (..)
     , Popper
@@ -37,6 +42,7 @@ module Network.HTTP.Client.Types
 import qualified Data.Typeable as T (Typeable)
 import Network.HTTP.Types
 import Control.Exception (Exception, SomeException, throwIO)
+import Data.Function (on)
 import Data.Word (Word64)
 import qualified Data.ByteString as S
 import qualified Data.ByteString.Lazy as L
@@ -263,26 +269,51 @@ 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.
+equal :: Cookie -> Cookie -> Bool
+equal 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'.
+equiv :: Cookie -> Cookie -> Bool
+equiv 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
+
+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)
+equalCookieJar :: CookieJar -> CookieJar -> Bool
+equalCookieJar (CJ cj1) (CJ cj2) = and $ zipWith equal cj1 cj2
+
+equivCookieJar :: CookieJar -> CookieJar -> Bool
+equivCookieJar cj1 cj2 = and $
+  zipWith equiv (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 equiv $ 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,7 +661,17 @@ 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)
+
+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' resp == responseClose' resp'
+    ]
 
 newtype ResponseClose = ResponseClose { runResponseClose :: IO () }
     deriving T.Typeable

http-client/test-nonet/Network/HTTP/ClientSpec.hs

@@ -17,11 +17,13 @@ import           Network.HTTP.Types.Header
 import qualified Network.Socket            as NS
 import           Test.Hspec
 import qualified Data.Streaming.Network    as N
+import qualified Data.Time                 as DT
 import qualified Data.ByteString           as S
 import qualified Data.ByteString.Lazy      as SL
 import           Data.ByteString.Lazy.Char8 () -- orphan instance
 import           Data.IORef
 import           System.Mem                (performGC)
+import qualified Web.Cookie                as WC
 
 -- See: https://github.com/snoyberg/http-client/issues/111#issuecomment-366526660
 notWindows :: Monad m => m () -> m ()
@@ -278,3 +280,36 @@ spec = describe "Client" $ do
       case parseRequest "https://o_O:18446744072699450606" of
         Left _ -> pure () :: IO ()
         Right req -> error $ "Invalid request: " ++ show req
+
+    describe "cookies" $ do
+      describe "equal vs. equiv" $ 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 (msg, f, countsForEquiv) = it msg $ do
+              cky <- make
+              cky `equal` f cky `shouldBe` False
+              when countsForEquiv $ cky `equiv` f cky `shouldBe` False
+
+        check `mapM_` modifications