1{-# OPTIONS_GHC -Wno-orphans #-} 2 3module CookieTest (cookieTest) where 4 5import Prelude hiding (exp) 6import Test.Hspec 7import qualified Data.ByteString as BS 8import Test.HUnit hiding (path) 9import Network.HTTP.Client 10import qualified Network.HTTP.Conduit as HC 11import Data.ByteString.UTF8 12import Data.Monoid 13import Data.Time.Clock 14import Data.Time.Calendar 15import qualified Data.CaseInsensitive as CI 16import Web.Cookie 17 18-- We use these Eq instances here because they make sense and may be added to the library in 19-- the future. We do not add them now because they would silently break the old Eq behavior, 20-- which was `equivCookie`. 21instance Eq Cookie where 22 (==) = equalCookie 23 24instance Eq CookieJar where 25 (==) = equalCookieJar 26 27instance Eq body => Eq (Response body) where 28 resp == resp' = and 29 [ responseStatus resp == responseStatus resp' 30 , responseVersion resp == responseVersion resp' 31 , responseHeaders resp == responseHeaders resp' 32 , responseBody resp == responseBody resp' 33 , responseCookieJar resp `equivCookieJar` responseCookieJar resp' -- ! 34 -- , responseClose -- ! 35 ] 36 37default_request :: HC.Request 38default_request = HC.parseRequest_ "http://www.google.com/" 39 40default_cookie :: Cookie 41default_cookie = Cookie { cookie_name = fromString "name" 42 , cookie_value = fromString "value" 43 , cookie_expiry_time = default_time 44 , cookie_domain = fromString "www.google.com" 45 , cookie_path = fromString "/" 46 , cookie_creation_time = default_time 47 , cookie_last_access_time = default_time 48 , cookie_persistent = False 49 , cookie_host_only = False 50 , cookie_secure_only = False 51 , cookie_http_only = False 52 } 53 54default_time :: UTCTime 55default_time = UTCTime (ModifiedJulianDay 56200) (secondsToDiffTime 0) 56 57default_diff_time :: DiffTime 58default_diff_time = secondsToDiffTime 1209600 59 60default_set_cookie :: SetCookie 61default_set_cookie = def { setCookieName = fromString "name" 62 , setCookieValue = fromString "value" 63 , setCookiePath = Just $ fromString "/" 64 , setCookieExpires = Just default_time 65 , setCookieMaxAge = Just default_diff_time 66 , setCookieDomain = Just $ fromString "www.google.com" 67 , setCookieHttpOnly = False 68 , setCookieSecure = False 69 } 70 71testValidIp :: IO () 72testValidIp = assertBool "Couldn't parse valid IP address" $ 73 isIpAddress $ fromString "1.2.3.4" 74 75testIpNumTooHigh :: IO () 76testIpNumTooHigh = assertBool "One of the digits in the IP address is too large" $ 77 not $ isIpAddress $ fromString "501.2.3.4" 78 79testTooManySegmentsInIp :: IO () 80testTooManySegmentsInIp = assertBool "Too many segments in the ip address" $ 81 not $ isIpAddress $ fromString "1.2.3.4.5" 82 83testCharsInIp :: IO () 84testCharsInIp = assertBool "Chars are not allowed in IP addresses" $ 85 not $ isIpAddress $ fromString "1.2a3.4.5" 86 87testDomainMatchesSuccess :: IO () 88testDomainMatchesSuccess = assertBool "Domains should match" $ 89 domainMatches (fromString "www.google.com") (fromString "google.com") 90 91testSameDomain :: IO () 92testSameDomain = assertBool "Same domain should match" $ 93 domainMatches domain domain 94 where domain = fromString "www.google.com" 95 96testSiblingDomain :: IO () 97testSiblingDomain = assertBool "Sibling domain should not match" $ 98 not $ domainMatches (fromString "www.google.com") (fromString "secure.google.com") 99 100testParentDomain :: IO () 101testParentDomain = assertBool "Parent domain should fail" $ 102 not $ domainMatches (fromString "google.com") (fromString "www.google.com") 103 104testNaiveSuffixDomain :: IO () 105testNaiveSuffixDomain = assertBool "Naively checking for suffix for domain matching should fail" $ 106 not $ domainMatches (fromString "agoogle.com") (fromString "google.com") 107 108testDefaultPath :: IO () 109testDefaultPath = assertEqual "Getting default path from a request" 110 (fromString "/") (defaultPath default_request) 111 112testShortDefaultPath :: IO () 113testShortDefaultPath = assertEqual "Getting default path from a short path" 114 (fromString "/") (defaultPath $ default_request {HC.path = fromString "/search"}) 115 116testPopulatedDefaultPath :: IO () 117testPopulatedDefaultPath = assertEqual "Getting default path from a request with a path" 118 (fromString "/search") (defaultPath $ default_request {HC.path = fromString "/search/term"}) 119 120testParamsDefaultPath :: IO () 121testParamsDefaultPath = assertEqual "Getting default path from a request with a path and GET params" 122 (fromString "/search") (defaultPath $ default_request {HC.path = fromString "/search/term?var=val"}) 123 124testDefaultPathEndingInSlash :: IO () 125testDefaultPathEndingInSlash = assertEqual "Getting default path that ends in a slash" 126 (fromString "/search/term") (defaultPath $ default_request {HC.path = fromString "/search/term/"}) 127 128testSamePathsMatch :: IO () 129testSamePathsMatch = assertBool "The same path should match" $ 130 pathMatches path' path' 131 where path' = fromString "/a/path" 132 133testPathSlashAtEnd :: IO () 134testPathSlashAtEnd = assertBool "Putting the slash at the end should still match paths" $ 135 pathMatches (fromString "/a/path/to/here") (fromString "/a/path/") 136 137testPathNoSlashAtEnd :: IO () 138testPathNoSlashAtEnd = assertBool "Not putting the slash at the end should still match paths" $ 139 pathMatches (fromString "/a/path/to/here") (fromString "/a/path") 140 141testDivergingPaths :: IO () 142testDivergingPaths = assertBool "Diverging paths don't match" $ 143 not $ pathMatches (fromString "/a/path/to/here") (fromString "/a/different/path") 144 145testCookieEqualitySuccess :: IO () 146testCookieEqualitySuccess = assertEqual "The same cookies should be equal" 147 cookie cookie 148 where cookie = default_cookie 149 150testCookieEqualityResiliance :: IO () 151testCookieEqualityResiliance = assertBool "Cookies should still be equal if extra options are changed" $ 152 (default_cookie {cookie_persistent = True}) `equivCookie` (default_cookie {cookie_host_only = True}) 153 154testDomainChangesEquality :: IO () 155testDomainChangesEquality = assertBool "Changing the domain should make cookies not equal" $ 156 default_cookie /= (default_cookie {cookie_domain = fromString "/search"}) 157 158testRemoveCookie :: IO () 159testRemoveCookie = assertEqual "Removing a cookie works" 160 (Just default_cookie, createCookieJar []) (removeExistingCookieFromCookieJar default_cookie $ createCookieJar [default_cookie]) 161 162testRemoveNonexistantCookie :: IO () 163testRemoveNonexistantCookie = assertEqual "Removing a nonexistent cookie doesn't work" 164 (Nothing, createCookieJar [default_cookie]) (removeExistingCookieFromCookieJar (default_cookie {cookie_name = fromString "key2"}) $ createCookieJar [default_cookie]) 165 166testRemoveCorrectCookie :: IO () 167testRemoveCorrectCookie = assertEqual "Removing only the correct cookie" 168 (Just search_for, createCookieJar [red_herring]) (removeExistingCookieFromCookieJar search_for $ createCookieJar [red_herring, search_for]) 169 where search_for = default_cookie {cookie_name = fromString "name1"} 170 red_herring = default_cookie {cookie_name = fromString "name2"} 171 172testEvictExpiredCookies :: IO () 173testEvictExpiredCookies = assertEqual "Evicting expired cookies works" 174 (createCookieJar [a, c]) (evictExpiredCookies (createCookieJar [a, b, c, d]) middle) 175 where a = default_cookie { cookie_name = fromString "a" 176 , cookie_expiry_time = UTCTime (ModifiedJulianDay 3) (secondsToDiffTime 0) 177 } 178 b = default_cookie { cookie_name = fromString "b" 179 , cookie_expiry_time = UTCTime (ModifiedJulianDay 1) (secondsToDiffTime 0) 180 } 181 c = default_cookie { cookie_name = fromString "c" 182 , cookie_expiry_time = UTCTime (ModifiedJulianDay 3) (secondsToDiffTime 0) 183 } 184 d = default_cookie { cookie_name = fromString "d" 185 , cookie_expiry_time = UTCTime (ModifiedJulianDay 1) (secondsToDiffTime 0) 186 } 187 middle = UTCTime (ModifiedJulianDay 2) (secondsToDiffTime 0) 188 189testEvictNoCookies :: IO () 190testEvictNoCookies = assertEqual "Evicting empty cookie jar" 191 (createCookieJar []) (evictExpiredCookies (createCookieJar []) middle) 192 where middle = UTCTime (ModifiedJulianDay 2) (secondsToDiffTime 0) 193 194testComputeCookieStringUpdateLastAccessTime :: IO () 195testComputeCookieStringUpdateLastAccessTime = assertEqual "Updates last access time upon using cookies" 196 (fromString "name=value", out_cookie_jar) (computeCookieString request cookie_jar now True) 197 where request = default_request 198 cookie_jar = createCookieJar [default_cookie] 199 now = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 1) 200 out_cookie_jar = createCookieJar [default_cookie {cookie_last_access_time = now}] 201 202testComputeCookieStringHostOnly :: IO () 203testComputeCookieStringHostOnly = assertEqual "Host only cookies should match host exactly" 204 (fromString "name=value", cookie_jar) (computeCookieString request cookie_jar default_time True) 205 where request = default_request 206 cookie_jar = createCookieJar [default_cookie {cookie_host_only = True}] 207 208testComputeCookieStringHostOnlyFilter :: IO () 209testComputeCookieStringHostOnlyFilter = assertEqual "Host only cookies shouldn't match subdomain" 210 (fromString "", cookie_jar) (computeCookieString request cookie_jar default_time True) 211 where request = default_request {HC.host = fromString "sub1.sub2.google.com"} 212 cookie_jar = createCookieJar [default_cookie { cookie_host_only = True 213 , cookie_domain = fromString "sub2.google.com" 214 } 215 ] 216 217testComputeCookieStringDomainMatching :: IO () 218testComputeCookieStringDomainMatching = assertEqual "Domain matching works for new requests" 219 (fromString "name=value", cookie_jar) (computeCookieString request cookie_jar default_time True) 220 where request = default_request {HC.host = fromString "sub1.sub2.google.com"} 221 cookie_jar = createCookieJar [default_cookie {cookie_domain = fromString "sub2.google.com"}] 222 223testComputeCookieStringPathMatching :: IO () 224testComputeCookieStringPathMatching = assertEqual "Path matching works for new requests" 225 (fromString "name=value", cookie_jar) (computeCookieString request cookie_jar default_time True) 226 where request = default_request {HC.path = fromString "/a/path/to/nowhere"} 227 cookie_jar = createCookieJar [default_cookie {cookie_path = fromString "/a/path"}] 228 229testComputeCookieStringPathMatchingFails :: IO () 230testComputeCookieStringPathMatchingFails = assertEqual "Path matching fails when it should" 231 (fromString "", cookie_jar) (computeCookieString request cookie_jar default_time True) 232 where request = default_request {HC.path = fromString "/a/different/path/to/nowhere"} 233 cookie_jar = createCookieJar [default_cookie {cookie_path = fromString "/a/path"}] 234 235testComputeCookieStringPathMatchingWithParms :: IO () 236testComputeCookieStringPathMatchingWithParms = assertEqual "Path matching succeeds when request has GET params" 237 (fromString "name=value", cookie_jar) (computeCookieString request cookie_jar default_time True) 238 where request = default_request {HC.path = fromString "/a/path/to/nowhere?var=val"} 239 cookie_jar = createCookieJar [default_cookie {cookie_path = fromString "/a/path"}] 240 241testComputeCookieStringSecure :: IO () 242testComputeCookieStringSecure = assertEqual "Secure flag filters properly" 243 (fromString "", cookie_jar) (computeCookieString default_request cookie_jar default_time True) 244 where cookie_jar = createCookieJar [default_cookie {cookie_secure_only = True}] 245 246testComputeCookieStringHttpOnly :: IO () 247testComputeCookieStringHttpOnly = assertEqual "http-only flag filters properly" 248 (fromString "", cookie_jar) (computeCookieString default_request cookie_jar default_time False) 249 where cookie_jar = createCookieJar [default_cookie {cookie_http_only = True}] 250 251testComputeCookieStringSort :: IO () 252testComputeCookieStringSort = do 253 assertEqual "Sorting works correctly (computed string)" (fst format_output) (fromString "c1=v1;c3=v3;c4=v4;c2=v2") 254 assertBool "Sorting works correctly (remaining jar)" $ (snd format_output) `equivCookieJar` cookie_jar_out 255 where now = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 11) 256 cookie_jar = createCookieJar [ default_cookie { cookie_name = fromString "c1" 257 , cookie_value = fromString "v1" 258 , cookie_path = fromString "/all/encompassing/request" 259 } 260 , default_cookie { cookie_name = fromString "c2" 261 , cookie_value = fromString "v2" 262 , cookie_path = fromString "/all" 263 } 264 , default_cookie { cookie_name = fromString "c3" 265 , cookie_value = fromString "v3" 266 , cookie_path = fromString "/all/encompassing" 267 , cookie_creation_time = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 1) 268 } 269 , default_cookie { cookie_name = fromString "c4" 270 , cookie_value = fromString "v4" 271 , cookie_path = fromString "/all/encompassing" 272 , cookie_creation_time = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 2) 273 } 274 ] 275 cookie_jar_out = createCookieJar [ default_cookie { cookie_name = fromString "c1" 276 , cookie_value = fromString "v1" 277 , cookie_path = fromString "/all/encompassing/request" 278 , cookie_last_access_time = now 279 } 280 , default_cookie { cookie_name = fromString "c2" 281 , cookie_value = fromString "v2" 282 , cookie_path = fromString "/all" 283 , cookie_last_access_time = now 284 } 285 , default_cookie { cookie_name = fromString "c3" 286 , cookie_value = fromString "v3" 287 , cookie_path = fromString "/all/encompassing" 288 , cookie_creation_time = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 1) 289 , cookie_last_access_time = now 290 } 291 , default_cookie { cookie_name = fromString "c4" 292 , cookie_value = fromString "v4" 293 , cookie_path = fromString "/all/encompassing" 294 , cookie_creation_time = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 2) 295 , cookie_last_access_time = now 296 } 297 ] 298 request = default_request {HC.path = fromString "/all/encompassing/request/path"} 299 format_output = computeCookieString request cookie_jar default_time False 300 301testInsertCookiesIntoRequestWorks :: IO () 302testInsertCookiesIntoRequestWorks = assertEqual "Inserting cookies works" 303 [(CI.mk $ fromString "Cookie", fromString "key=val")] out_headers 304 where out_headers = HC.requestHeaders req 305 (req, _) = insertCookiesIntoRequest req' cookie_jar default_time 306 cookie_jar = createCookieJar [ default_cookie { cookie_name = fromString "key" 307 , cookie_value = fromString "val" 308 } 309 ] 310 req' = default_request {HC.requestHeaders = [(CI.mk $ fromString "Cookie", 311 fromString "otherkey=otherval")]} 312 313testReceiveSetCookie :: IO () 314testReceiveSetCookie = assertBool "Receiving a Set-Cookie" $ 315 (createCookieJar [default_cookie]) `equivCookieJar` (receiveSetCookie default_set_cookie default_request default_time True $ createCookieJar []) 316 317testReceiveSetCookieTrailingDot :: IO () 318testReceiveSetCookieTrailingDot = assertEqual "Receiving a Set-Cookie with a trailing domain dot" 319 (createCookieJar []) (receiveSetCookie set_cookie default_request default_time True $ createCookieJar []) 320 where set_cookie = default_set_cookie {setCookieDomain = Just $ fromString "www.google.com."} 321 322testReceiveSetCookieLeadingDot :: IO () 323testReceiveSetCookieLeadingDot = assertBool "Receiving a Set-Cookie with a leading domain dot" $ 324 (createCookieJar [default_cookie]) `equivCookieJar` (receiveSetCookie set_cookie default_request default_time True $ createCookieJar []) 325 where set_cookie = default_set_cookie {setCookieDomain = Just $ fromString ".www.google.com"} 326 327testReceiveSetCookieNoDomain :: IO () 328testReceiveSetCookieNoDomain = assertBool "Receiving cookie without domain" $ 329 (createCookieJar [default_cookie]) `equivCookieJar` (receiveSetCookie set_cookie default_request default_time True $ createCookieJar []) 330 where set_cookie = default_set_cookie {setCookieDomain = Nothing} 331 332testReceiveSetCookieEmptyDomain :: IO () 333testReceiveSetCookieEmptyDomain = assertBool "Receiving cookie with empty domain" $ 334 (createCookieJar [default_cookie]) `equivCookieJar` (receiveSetCookie set_cookie default_request default_time True $ createCookieJar []) 335 where set_cookie = default_set_cookie {setCookieDomain = Just BS.empty} 336 337-- Can't test public suffixes until that module is written 338 339testReceiveSetCookieNonMatchingDomain :: IO () 340testReceiveSetCookieNonMatchingDomain = assertEqual "Receiving cookie with non-matching domain" 341 (createCookieJar []) (receiveSetCookie set_cookie default_request default_time True $ createCookieJar []) 342 where set_cookie = default_set_cookie {setCookieDomain = Just $ fromString "www.wikipedia.org"} 343 344testReceiveSetCookieHostOnly :: IO () 345testReceiveSetCookieHostOnly = assertBool "Checking host-only flag gets set" $ 346 cookie_host_only $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar [] 347 where set_cookie = default_set_cookie {setCookieDomain = Nothing} 348 349testReceiveSetCookieHostOnlyNotSet :: IO () 350testReceiveSetCookieHostOnlyNotSet = assertBool "Checking host-only flag doesn't get set" $ 351 not $ cookie_host_only $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar [] 352 where set_cookie = default_set_cookie {setCookieDomain = Just $ fromString "google.com"} 353 354testReceiveSetCookieHttpOnly :: IO () 355testReceiveSetCookieHttpOnly = assertBool "Checking http-only flag gets set" $ 356 cookie_http_only $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar [] 357 where set_cookie = default_set_cookie {setCookieHttpOnly = True} 358 359testReceiveSetCookieHttpOnlyNotSet :: IO () 360testReceiveSetCookieHttpOnlyNotSet = assertBool "Checking http-only flag doesn't get set" $ 361 not $ cookie_http_only $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar [] 362 where set_cookie = default_set_cookie {setCookieHttpOnly = False} 363 364testReceiveSetCookieHttpOnlyDrop :: IO () 365testReceiveSetCookieHttpOnlyDrop = assertEqual "Checking non http request gets dropped" 366 (createCookieJar []) (receiveSetCookie set_cookie default_request default_time False $ createCookieJar []) 367 where set_cookie = default_set_cookie {setCookieHttpOnly = True} 368 369testReceiveSetCookieName :: IO () 370testReceiveSetCookieName = assertEqual "Name gets set correctly" 371 (fromString "name") (cookie_name $ head $ destroyCookieJar $ receiveSetCookie default_set_cookie default_request default_time True $ createCookieJar []) 372 373testReceiveSetCookieValue :: IO () 374testReceiveSetCookieValue = assertEqual "Value gets set correctly" 375 (fromString "value") (cookie_value $ head $ destroyCookieJar $ receiveSetCookie default_set_cookie default_request default_time True $ createCookieJar []) 376 377testReceiveSetCookieExpiry :: IO () 378testReceiveSetCookieExpiry = assertEqual "Expiry gets set correctly" 379 now_plus_diff_time (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie default_set_cookie default_request default_time True $ createCookieJar []) 380 where now_plus_diff_time = ((fromRational $ toRational default_diff_time) `addUTCTime` default_time) 381 382testReceiveSetCookieNoMaxAge :: IO () 383testReceiveSetCookieNoMaxAge = assertEqual "Expiry is based on the given value" 384 default_time (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie cookie_without_max_age default_request default_time True $ createCookieJar []) 385 where cookie_without_max_age = default_set_cookie {setCookieMaxAge = Nothing} 386 387testReceiveSetCookieNoExpiry :: IO () 388testReceiveSetCookieNoExpiry = assertEqual "Expiry is based on max age" 389 now_plus_diff_time (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie cookie_without_expiry default_request default_time True $ createCookieJar []) 390 where now_plus_diff_time = ((fromRational $ toRational default_diff_time) `addUTCTime` default_time) 391 cookie_without_expiry = default_set_cookie {setCookieExpires = Nothing} 392 393testReceiveSetCookieNoExpiryNoMaxAge :: IO () 394testReceiveSetCookieNoExpiryNoMaxAge = assertBool "Expiry is set to a future date" $ 395 default_time < (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie basic_cookie default_request default_time True $ createCookieJar []) 396 where basic_cookie = default_set_cookie { setCookieExpires = Nothing, setCookieMaxAge = Nothing } 397 398testReceiveSetCookiePath :: IO () 399testReceiveSetCookiePath = assertEqual "Path gets set correctly" 400 (fromString "/a/path") (cookie_path $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar []) 401 where set_cookie = default_set_cookie {setCookiePath = Just $ fromString "/a/path"} 402 403testReceiveSetCookieNoPath :: IO () 404testReceiveSetCookieNoPath = assertEqual "Path gets set correctly when nonexistent" 405 (fromString "/a/path/to") (cookie_path $ head $ destroyCookieJar $ receiveSetCookie set_cookie request default_time True $ createCookieJar []) 406 where set_cookie = default_set_cookie {setCookiePath = Nothing} 407 request = default_request {HC.path = fromString "/a/path/to/nowhere"} 408 409testReceiveSetCookieCreationTime :: IO () 410testReceiveSetCookieCreationTime = assertEqual "Creation time gets set correctly" 411 now (cookie_creation_time $ head $ destroyCookieJar $ receiveSetCookie default_set_cookie default_request now True $ createCookieJar []) 412 where now = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 1) 413 414testReceiveSetCookieAccessTime :: IO () 415testReceiveSetCookieAccessTime = assertEqual "Last access time gets set correctly" 416 now (cookie_last_access_time $ head $ destroyCookieJar $ receiveSetCookie default_set_cookie default_request now True $ createCookieJar []) 417 where now = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 1) 418 419testReceiveSetCookiePersistent :: IO () 420testReceiveSetCookiePersistent = assertBool "Persistent flag gets set correctly" $ 421 cookie_persistent $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar [] 422 where set_cookie = default_set_cookie {setCookieExpires = Just default_time} 423 424testReceiveSetCookieSecure :: IO () 425testReceiveSetCookieSecure = assertBool "Secure flag gets set correctly" $ 426 cookie_secure_only $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar [] 427 where set_cookie = default_set_cookie {setCookieSecure = True} 428 429testReceiveSetCookieMaxAge :: IO () 430testReceiveSetCookieMaxAge = assertEqual "Max-Age gets set correctly" 431 total (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request now True $ createCookieJar []) 432 where set_cookie = default_set_cookie { setCookieExpires = Nothing 433 , setCookieMaxAge = Just $ secondsToDiffTime 10 434 } 435 now = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 12) 436 total = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 22) 437 438testReceiveSetCookiePreferMaxAge :: IO () 439testReceiveSetCookiePreferMaxAge = assertEqual "Max-Age is preferred over Expires" 440 total (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request now True $ createCookieJar []) 441 where set_cookie = default_set_cookie { setCookieExpires = Just exp 442 , setCookieMaxAge = Just $ secondsToDiffTime 10 443 } 444 exp = UTCTime (ModifiedJulianDay 11) (secondsToDiffTime 5) 445 now = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 12) 446 total = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 22) 447 448testReceiveSetCookieExisting :: IO () 449testReceiveSetCookieExisting = assertEqual "Existing cookie gets updated" 450 t (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar [default_cookie]) 451 where set_cookie = default_set_cookie { setCookieExpires = Just t 452 , setCookieMaxAge = Nothing 453 } 454 t = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 12) 455 456testReceiveSetCookieExistingCreation :: IO () 457testReceiveSetCookieExistingCreation = assertEqual "Creation time gets updated in existing cookie" 458 default_time (cookie_creation_time $ head $ destroyCookieJar $ receiveSetCookie default_set_cookie default_request now True $ createCookieJar [default_cookie]) 459 where now = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 12) 460 461testReceiveSetCookieExistingHttpOnly :: IO () 462testReceiveSetCookieExistingHttpOnly = assertEqual "Existing http-only cookie gets dropped" 463 default_time (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie default_set_cookie default_request default_time False $ createCookieJar [existing_cookie]) 464 where existing_cookie = default_cookie {cookie_http_only = True} 465 466testMonoidPreferRecent :: IO () 467testMonoidPreferRecent = assertEqual "Monoid prefers more recent cookies" 468 (cct $ createCookieJar [c2]) (cct $ createCookieJar [c1] `Data.Monoid.mappend` createCookieJar [c2]) 469 where c1 = default_cookie {cookie_creation_time = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 1)} 470 c2 = default_cookie {cookie_creation_time = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 2)} 471 cct cj = cookie_creation_time $ head $ destroyCookieJar cj 472 473ipParseTests :: Spec 474ipParseTests = do 475 it "Valid IP" testValidIp 476 it "Digit Too High" testIpNumTooHigh 477 it "Too Many Segments" testTooManySegmentsInIp 478 it "Chars in IP" testCharsInIp 479 480domainMatchingTests :: Spec 481domainMatchingTests = do 482 it "Should Match" testDomainMatchesSuccess 483 it "Same Domain" testSameDomain 484 it "Sibling Domain" testSiblingDomain 485 it "Parent Domain" testParentDomain 486 it "Checking for Naive suffix-check" testNaiveSuffixDomain 487 488defaultPathTests :: Spec 489defaultPathTests = do 490 it "Basic default path test" testDefaultPath 491 it "Basic populated default path" testPopulatedDefaultPath 492 it "Default path from request with GET params works" testParamsDefaultPath 493 it "Getting a default path that ends in a slash" testDefaultPathEndingInSlash 494 it "Getting a short default path" testShortDefaultPath 495 496pathMatchingTests :: Spec 497pathMatchingTests = do 498 it "Same paths match" testSamePathsMatch 499 it "Putting slash at end" testPathSlashAtEnd 500 it "Not putting slash at end" testPathNoSlashAtEnd 501 it "Diverging paths don't match" testDivergingPaths 502 503equalityTests :: Spec 504equalityTests = do 505 it "The same cookie should be equal to itself" testCookieEqualitySuccess 506 it "Changing extra options shouldn't change equality" testCookieEqualityResiliance 507 it "Changing a cookie's domain should change its equality" testDomainChangesEquality 508 509removeTests :: Spec 510removeTests = do 511 it "Removing a cookie works" testRemoveCookie 512 it "Removing a nonexistent cookie doesn't work" testRemoveNonexistantCookie 513 it "Removing the correct cookie" testRemoveCorrectCookie 514 515evictionTests :: Spec 516evictionTests = do 517 it "Testing eviction" testEvictExpiredCookies 518 it "Evicting from empty cookie jar" testEvictNoCookies 519 520sendingTests :: Spec 521sendingTests = do 522 it "Updates last access time upon using cookies" testComputeCookieStringUpdateLastAccessTime 523 it "Host-only flag matches exact host" testComputeCookieStringHostOnly 524 it "Host-only flag doesn't match subdomain" testComputeCookieStringHostOnlyFilter 525 it "Domain matching works properly" testComputeCookieStringDomainMatching 526 it "Path matching works" testComputeCookieStringPathMatching 527 it "Path matching fails when it should" testComputeCookieStringPathMatchingFails 528 it "Path matching succeeds when request has GET params" testComputeCookieStringPathMatchingWithParms 529 it "Secure flag filters correctly" testComputeCookieStringSecure 530 it "Http-only flag filters correctly" testComputeCookieStringHttpOnly 531 it "Sorting works correctly" testComputeCookieStringSort 532 it "Inserting cookie header works" testInsertCookiesIntoRequestWorks 533 534receivingTests :: Spec 535receivingTests = do 536 it "Can receive set-cookie" testReceiveSetCookie 537 it "Receiving a Set-Cookie with a trailing dot on the domain" testReceiveSetCookieTrailingDot 538 it "Receiving a Set-Cookie with a leading dot on the domain" testReceiveSetCookieLeadingDot 539 it "Set-Cookie with no domain" testReceiveSetCookieNoDomain 540 it "Set-Cookie with empty domain" testReceiveSetCookieEmptyDomain 541 it "Set-Cookie with non-matching domain" testReceiveSetCookieNonMatchingDomain 542 it "Host-only flag gets set" testReceiveSetCookieHostOnly 543 it "Host-only flag doesn't get set" testReceiveSetCookieHostOnlyNotSet 544 it "Http-only flag gets set" testReceiveSetCookieHttpOnly 545 it "Http-only flag doesn't get set" testReceiveSetCookieHttpOnlyNotSet 546 it "Checking non http request gets dropped" testReceiveSetCookieHttpOnlyDrop 547 it "Name gets set correctly" testReceiveSetCookieName 548 it "Value gets set correctly" testReceiveSetCookieValue 549 it "Expiry gets set correctly" testReceiveSetCookieExpiry 550 it "Expiry gets set based on max age if no expiry is given" testReceiveSetCookieNoExpiry 551 it "Expiry gets set based on given value if no max age is given" testReceiveSetCookieNoMaxAge 552 it "Expiry gets set to a future date if no expiry and no max age are given" testReceiveSetCookieNoExpiryNoMaxAge 553 it "Path gets set correctly when nonexistent" testReceiveSetCookieNoPath 554 it "Path gets set correctly" testReceiveSetCookiePath 555 it "Creation time gets set correctly" testReceiveSetCookieCreationTime 556 it "Last access time gets set correctly" testReceiveSetCookieAccessTime 557 it "Persistent flag gets set correctly" testReceiveSetCookiePersistent 558 it "Existing cookie gets updated" testReceiveSetCookieExisting 559 it "Creation time gets updated in existing cookie" testReceiveSetCookieExistingCreation 560 it "Existing http-only cookie gets dropped" testReceiveSetCookieExistingHttpOnly 561 it "Secure flag gets set correctly" testReceiveSetCookieSecure 562 it "Max-Age flag gets set correctly" testReceiveSetCookieMaxAge 563 it "Max-Age is preferred over Expires" testReceiveSetCookiePreferMaxAge 564 565monoidTests :: Spec 566monoidTests = do 567 it "Monoid prefers more recent cookies" testMonoidPreferRecent 568 569cookieTest :: Spec 570cookieTest = do 571 describe "ipParseTests" ipParseTests 572 describe "domainMatchingTests" domainMatchingTests 573 describe "defaultPathTests" defaultPathTests 574 describe "pathMatchingTests" pathMatchingTests 575 describe "equalityTests" equalityTests 576 describe "removeTests" removeTests 577 describe "evictionTests" evictionTests 578 describe "sendingTests" sendingTests 579 describe "receivingTests" receivingTests 580 describe "monoidTest" monoidTests 581