diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/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) diff --git a/Network/HTTP/Client.hs b/Network/HTTP/Client.hs --- a/Network/HTTP/Client.hs +++ b/Network/HTTP/Client.hs @@ -192,7 +192,12 @@ , HttpException (..) , HttpExceptionContent (..) , Cookie (..) + , equalCookie + , equivCookie + , compareCookies , CookieJar + , equalCookieJar + , equivCookieJar , Proxy (..) , withConnection -- * Cookies @@ -211,7 +216,6 @@ 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) diff --git a/Network/HTTP/Client/Cookies.hs b/Network/HTTP/Client/Cookies.hs --- a/Network/HTTP/Client/Cookies.hs +++ b/Network/HTTP/Client/Cookies.hs @@ -100,7 +100,7 @@ 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 @@ | 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''' diff --git a/Network/HTTP/Client/Types.hs b/Network/HTTP/Client/Types.hs --- a/Network/HTTP/Client/Types.hs +++ b/Network/HTTP/Client/Types.hs @@ -13,7 +13,12 @@ , throwHttp , toHttpException , Cookie (..) + , equalCookie + , equivCookie + , compareCookies , CookieJar (..) + , equalCookieJar + , equivCookieJar , Proxy (..) , RequestBody (..) , Popper @@ -263,26 +268,64 @@ 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 +-- | 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 + ] -instance Ord Cookie where - compare c1 c2 +-- | 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 @@ -- -- 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 . diff --git a/http-client.cabal b/http-client.cabal --- a/http-client.cabal +++ b/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: . homepage: https://github.com/snoyberg/http-client @@ -125,6 +125,7 @@ , hspec , monad-control , bytestring + , cookie , text , http-types , blaze-builder diff --git a/test-nonet/Network/HTTP/Client/CookieSpec.hs b/test-nonet/Network/HTTP/Client/CookieSpec.hs --- a/test-nonet/Network/HTTP/Client/CookieSpec.hs +++ b/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 @@ 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 @@ 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