File: CookieTest.hs

package info (click to toggle)
haskell-http-conduit 2.3.2-2
  • links: PTS, VCS
  • area: main
  • in suites: bullseye, buster, sid
  • size: 192 kB
  • sloc: haskell: 1,528; makefile: 3
file content (558 lines) | stat: -rw-r--r-- 32,579 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
module CookieTest (cookieTest) where

import Prelude hiding (exp)
import Test.Hspec
import qualified Data.ByteString as BS
import Test.HUnit hiding (path)
import Network.HTTP.Client
import qualified Network.HTTP.Conduit as HC
import Data.ByteString.UTF8
import Data.Monoid
import Data.Time.Clock
import Data.Time.Calendar
import qualified Data.CaseInsensitive as CI
import Web.Cookie

default_request :: HC.Request
default_request = HC.parseRequest_ "http://www.google.com/"

default_cookie :: Cookie
default_cookie = Cookie { cookie_name = fromString "name"
                        , cookie_value = fromString "value"
                        , cookie_expiry_time = default_time
                        , cookie_domain = fromString "www.google.com"
                        , cookie_path = fromString "/"
                        , cookie_creation_time = default_time
                        , cookie_last_access_time = default_time
                        , cookie_persistent = False
                        , cookie_host_only = False
                        , cookie_secure_only = False
                        , cookie_http_only = False
                        }

default_time :: UTCTime
default_time = UTCTime (ModifiedJulianDay 56200) (secondsToDiffTime 0)

default_diff_time :: DiffTime
default_diff_time = secondsToDiffTime 1209600

default_set_cookie :: SetCookie
default_set_cookie = def       { setCookieName = fromString "name"
                               , setCookieValue = fromString "value"
                               , setCookiePath = Just $ fromString "/"
                               , setCookieExpires = Just default_time
                               , setCookieMaxAge = Just default_diff_time
                               , setCookieDomain = Just $ fromString "www.google.com"
                               , setCookieHttpOnly = False
                               , setCookieSecure = False
                               }

testValidIp :: IO ()
testValidIp = assertBool "Couldn't parse valid IP address" $
  isIpAddress $ fromString "1.2.3.4"

testIpNumTooHigh :: IO ()
testIpNumTooHigh = assertBool "One of the digits in the IP address is too large" $
  not $ isIpAddress $ fromString "501.2.3.4"

testTooManySegmentsInIp :: IO ()
testTooManySegmentsInIp = assertBool "Too many segments in the ip address" $
  not $ isIpAddress $ fromString "1.2.3.4.5"

testCharsInIp :: IO ()
testCharsInIp = assertBool "Chars are not allowed in IP addresses" $
  not $ isIpAddress $ fromString "1.2a3.4.5"

testDomainMatchesSuccess :: IO ()
testDomainMatchesSuccess = assertBool "Domains should match" $
  domainMatches (fromString "www.google.com") (fromString "google.com")

testSameDomain :: IO ()
testSameDomain = assertBool "Same domain should match" $
  domainMatches domain domain
  where domain = fromString "www.google.com"

testSiblingDomain :: IO ()
testSiblingDomain = assertBool "Sibling domain should not match" $
  not $ domainMatches (fromString "www.google.com") (fromString "secure.google.com")

testParentDomain :: IO ()
testParentDomain = assertBool "Parent domain should fail" $
  not $ domainMatches (fromString "google.com") (fromString "www.google.com")

testNaiveSuffixDomain :: IO ()
testNaiveSuffixDomain = assertBool "Naively checking for suffix for domain matching should fail" $
  not $ domainMatches (fromString "agoogle.com") (fromString "google.com")

testDefaultPath :: IO ()
testDefaultPath = assertEqual "Getting default path from a request"
  (fromString "/") (defaultPath default_request)

testShortDefaultPath :: IO ()
testShortDefaultPath = assertEqual "Getting default path from a short path"
  (fromString "/") (defaultPath $ default_request {HC.path = fromString "/search"})

testPopulatedDefaultPath :: IO ()
testPopulatedDefaultPath = assertEqual "Getting default path from a request with a path"
  (fromString "/search") (defaultPath $ default_request {HC.path = fromString "/search/term"})

testParamsDefaultPath :: IO ()
testParamsDefaultPath = assertEqual "Getting default path from a request with a path and GET params"
  (fromString "/search") (defaultPath $ default_request {HC.path = fromString "/search/term?var=val"})

testDefaultPathEndingInSlash :: IO ()
testDefaultPathEndingInSlash = assertEqual "Getting default path that ends in a slash"
  (fromString "/search/term") (defaultPath $ default_request {HC.path = fromString "/search/term/"})

testSamePathsMatch :: IO ()
testSamePathsMatch = assertBool "The same path should match" $
  pathMatches path' path'
  where path' = fromString "/a/path"

testPathSlashAtEnd :: IO ()
testPathSlashAtEnd = assertBool "Putting the slash at the end should still match paths" $
  pathMatches (fromString "/a/path/to/here") (fromString "/a/path/")

testPathNoSlashAtEnd :: IO ()
testPathNoSlashAtEnd = assertBool "Not putting the slash at the end should still match paths" $
  pathMatches (fromString "/a/path/to/here") (fromString "/a/path")

testDivergingPaths :: IO ()
testDivergingPaths = assertBool "Diverging paths don't match" $
  not $ pathMatches (fromString "/a/path/to/here") (fromString "/a/different/path")

testCookieEqualitySuccess :: IO ()
testCookieEqualitySuccess = assertEqual "The same cookies should be equal"
  cookie cookie
  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})

testDomainChangesEquality :: IO ()
testDomainChangesEquality = assertBool "Changing the domain should make cookies not equal" $
  default_cookie /= (default_cookie {cookie_domain = fromString "/search"})

testRemoveCookie :: IO ()
testRemoveCookie = assertEqual "Removing a cookie works"
  (Just default_cookie, createCookieJar []) (removeExistingCookieFromCookieJar default_cookie $ createCookieJar [default_cookie])

testRemoveNonexistantCookie :: IO ()
testRemoveNonexistantCookie = assertEqual "Removing a nonexistent cookie doesn't work"
  (Nothing, createCookieJar [default_cookie]) (removeExistingCookieFromCookieJar (default_cookie {cookie_name = fromString "key2"}) $ createCookieJar [default_cookie])

testRemoveCorrectCookie :: IO ()
testRemoveCorrectCookie = assertEqual "Removing only the correct cookie"
  (Just search_for, createCookieJar [red_herring]) (removeExistingCookieFromCookieJar search_for $ createCookieJar [red_herring, search_for])
  where search_for = default_cookie {cookie_name = fromString "name1"}
        red_herring = default_cookie {cookie_name = fromString "name2"}

testEvictExpiredCookies :: IO ()
testEvictExpiredCookies = assertEqual "Evicting expired cookies works"
  (createCookieJar [a, c]) (evictExpiredCookies (createCookieJar [a, b, c, d]) middle)
  where a = default_cookie { cookie_name = fromString "a"
                           , cookie_expiry_time = UTCTime (ModifiedJulianDay 3) (secondsToDiffTime 0)
                           }
        b = default_cookie { cookie_name = fromString "b"
                           , cookie_expiry_time = UTCTime (ModifiedJulianDay 1) (secondsToDiffTime 0)
                           }
        c = default_cookie { cookie_name = fromString "c"
                           , cookie_expiry_time = UTCTime (ModifiedJulianDay 3) (secondsToDiffTime 0)
                           }
        d = default_cookie { cookie_name = fromString "d"
                           , cookie_expiry_time = UTCTime (ModifiedJulianDay 1) (secondsToDiffTime 0)
                           }
        middle = UTCTime (ModifiedJulianDay 2) (secondsToDiffTime 0)

testEvictNoCookies :: IO ()
testEvictNoCookies = assertEqual "Evicting empty cookie jar"
  (createCookieJar []) (evictExpiredCookies (createCookieJar []) middle)
  where middle = UTCTime (ModifiedJulianDay 2) (secondsToDiffTime 0)

testComputeCookieStringUpdateLastAccessTime :: IO ()
testComputeCookieStringUpdateLastAccessTime = assertEqual "Updates last access time upon using cookies"
  (fromString "name=value", out_cookie_jar) (computeCookieString request cookie_jar now True)
  where request = default_request
        cookie_jar = createCookieJar [default_cookie]
        now = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 1)
        out_cookie_jar = createCookieJar [default_cookie {cookie_last_access_time = now}]

testComputeCookieStringHostOnly :: IO ()
testComputeCookieStringHostOnly = assertEqual "Host only cookies should match host exactly"
  (fromString "name=value", cookie_jar) (computeCookieString request cookie_jar default_time True)
  where request = default_request
        cookie_jar = createCookieJar [default_cookie {cookie_host_only = True}]

testComputeCookieStringHostOnlyFilter :: IO ()
testComputeCookieStringHostOnlyFilter = assertEqual "Host only cookies shouldn't match subdomain"
  (fromString "", cookie_jar) (computeCookieString request cookie_jar default_time True)
  where request = default_request {HC.host = fromString "sub1.sub2.google.com"}
        cookie_jar = createCookieJar [default_cookie { cookie_host_only = True
                                                     , cookie_domain = fromString "sub2.google.com"
                                                     }
                                     ]

testComputeCookieStringDomainMatching :: IO ()
testComputeCookieStringDomainMatching = assertEqual "Domain matching works for new requests"
  (fromString "name=value", cookie_jar) (computeCookieString request cookie_jar default_time True)
  where request = default_request {HC.host = fromString "sub1.sub2.google.com"}
        cookie_jar = createCookieJar [default_cookie {cookie_domain = fromString "sub2.google.com"}]

testComputeCookieStringPathMatching :: IO ()
testComputeCookieStringPathMatching = assertEqual "Path matching works for new requests"
  (fromString "name=value", cookie_jar) (computeCookieString request cookie_jar default_time True)
  where request = default_request {HC.path = fromString "/a/path/to/nowhere"}
        cookie_jar = createCookieJar [default_cookie {cookie_path = fromString "/a/path"}]

testComputeCookieStringPathMatchingFails :: IO ()
testComputeCookieStringPathMatchingFails = assertEqual "Path matching fails when it should"
  (fromString "", cookie_jar) (computeCookieString request cookie_jar default_time True)
  where request = default_request {HC.path = fromString "/a/different/path/to/nowhere"}
        cookie_jar = createCookieJar [default_cookie {cookie_path = fromString "/a/path"}]

testComputeCookieStringPathMatchingWithParms :: IO ()
testComputeCookieStringPathMatchingWithParms = assertEqual "Path matching succeeds when request has GET params"
  (fromString "name=value", cookie_jar) (computeCookieString request cookie_jar default_time True)
  where request = default_request {HC.path = fromString "/a/path/to/nowhere?var=val"}
        cookie_jar = createCookieJar [default_cookie {cookie_path = fromString "/a/path"}]

testComputeCookieStringSecure :: IO ()
testComputeCookieStringSecure = assertEqual "Secure flag filters properly"
  (fromString "", cookie_jar) (computeCookieString default_request cookie_jar default_time True)
  where cookie_jar = createCookieJar [default_cookie {cookie_secure_only = True}]

testComputeCookieStringHttpOnly :: IO ()
testComputeCookieStringHttpOnly = assertEqual "http-only flag filters properly"
  (fromString "", cookie_jar) (computeCookieString default_request cookie_jar default_time False)
  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
  where now = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 11)
        cookie_jar = createCookieJar [ default_cookie { cookie_name = fromString "c1"
                                                      , cookie_value = fromString "v1"
                                                      , cookie_path = fromString "/all/encompassing/request"
                                                      }
                                     , default_cookie { cookie_name = fromString "c2"
                                                      , cookie_value = fromString "v2"
                                                      , cookie_path = fromString "/all"
                                                      }
                                     , default_cookie { cookie_name = fromString "c3"
                                                      , cookie_value = fromString "v3"
                                                      , cookie_path = fromString "/all/encompassing"
                                                      , cookie_creation_time = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 1)
                                                      }
                                     , default_cookie { cookie_name = fromString "c4"
                                                      , cookie_value = fromString "v4"
                                                      , cookie_path = fromString "/all/encompassing"
                                                      , cookie_creation_time = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 2)
                                                      }
                                     ]
        cookie_jar_out = createCookieJar [ default_cookie { cookie_name = fromString "c1"
                                                          , cookie_value = fromString "v1"
                                                          , cookie_path = fromString "/all/encompassing/request"
                                                          , cookie_last_access_time = now
                                                          }
                                         , default_cookie { cookie_name = fromString "c2"
                                                          , cookie_value = fromString "v2"
                                                          , cookie_path = fromString "/all"
                                                          , cookie_last_access_time = now
                                                          }
                                         , default_cookie { cookie_name = fromString "c3"
                                                          , cookie_value = fromString "v3"
                                                          , cookie_path = fromString "/all/encompassing"
                                                          , cookie_creation_time = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 1)
                                                          , cookie_last_access_time = now
                                                          }
                                         , default_cookie { cookie_name = fromString "c4"
                                                          , cookie_value = fromString "v4"
                                                          , cookie_path = fromString "/all/encompassing"
                                                          , cookie_creation_time = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 2)
                                                          , cookie_last_access_time = now
                                                          }
                                         ]
        request = default_request {HC.path = fromString "/all/encompassing/request/path"}
        format_output = computeCookieString request cookie_jar default_time False

testInsertCookiesIntoRequestWorks :: IO ()
testInsertCookiesIntoRequestWorks = assertEqual "Inserting cookies works"
  [(CI.mk $ fromString "Cookie", fromString "key=val")] out_headers
  where out_headers = HC.requestHeaders req
        (req, _) = insertCookiesIntoRequest req' cookie_jar default_time
        cookie_jar = createCookieJar [ default_cookie { cookie_name = fromString "key"
                                                      , cookie_value = fromString "val"
                                                      }
                                     ]
        req' = default_request {HC.requestHeaders = [(CI.mk $ fromString "Cookie",
                                                      fromString "otherkey=otherval")]}

testReceiveSetCookie :: IO ()
testReceiveSetCookie = assertEqual "Receiving a Set-Cookie"
  (createCookieJar [default_cookie]) (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 [])
  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 [])
  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 [])
  where set_cookie = default_set_cookie {setCookieDomain = Just BS.empty}

-- Can't test public suffixes until that module is written

testReceiveSetCookieNonMatchingDomain :: IO ()
testReceiveSetCookieNonMatchingDomain = assertEqual "Receiving cookie with non-matching domain"
  (createCookieJar []) (receiveSetCookie set_cookie default_request default_time True $ createCookieJar [])
  where set_cookie = default_set_cookie {setCookieDomain = Just $ fromString "www.wikipedia.org"}

testReceiveSetCookieHostOnly :: IO ()
testReceiveSetCookieHostOnly = assertBool "Checking host-only flag gets set" $
  cookie_host_only $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar []
  where set_cookie = default_set_cookie {setCookieDomain = Nothing}

testReceiveSetCookieHostOnlyNotSet :: IO ()
testReceiveSetCookieHostOnlyNotSet = assertBool "Checking host-only flag doesn't get set" $
  not $ cookie_host_only $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar []
  where set_cookie = default_set_cookie {setCookieDomain = Just $ fromString "google.com"}

testReceiveSetCookieHttpOnly :: IO ()
testReceiveSetCookieHttpOnly = assertBool "Checking http-only flag gets set" $
  cookie_http_only $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar []
  where set_cookie = default_set_cookie {setCookieHttpOnly = True}

testReceiveSetCookieHttpOnlyNotSet :: IO ()
testReceiveSetCookieHttpOnlyNotSet = assertBool "Checking http-only flag doesn't get set" $
  not $ cookie_http_only $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar []
  where set_cookie = default_set_cookie {setCookieHttpOnly = False}

testReceiveSetCookieHttpOnlyDrop :: IO ()
testReceiveSetCookieHttpOnlyDrop = assertEqual "Checking non http request gets dropped"
  (createCookieJar []) (receiveSetCookie set_cookie default_request default_time False $ createCookieJar [])
  where set_cookie = default_set_cookie {setCookieHttpOnly = True}

testReceiveSetCookieName :: IO ()
testReceiveSetCookieName = assertEqual "Name gets set correctly"
  (fromString "name") (cookie_name $ head $ destroyCookieJar $ receiveSetCookie default_set_cookie default_request default_time True $ createCookieJar [])

testReceiveSetCookieValue :: IO ()
testReceiveSetCookieValue = assertEqual "Value gets set correctly"
  (fromString "value") (cookie_value $ head $ destroyCookieJar $ receiveSetCookie default_set_cookie default_request default_time True $ createCookieJar [])

testReceiveSetCookieExpiry :: IO ()
testReceiveSetCookieExpiry = assertEqual "Expiry gets set correctly"
  now_plus_diff_time (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie default_set_cookie default_request default_time True $ createCookieJar [])
  where now_plus_diff_time = ((fromRational $ toRational default_diff_time) `addUTCTime` default_time)

testReceiveSetCookieNoMaxAge :: IO ()
testReceiveSetCookieNoMaxAge = assertEqual "Expiry is based on the given value"
  default_time (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie cookie_without_max_age default_request default_time True $ createCookieJar [])
  where cookie_without_max_age = default_set_cookie {setCookieMaxAge = Nothing}

testReceiveSetCookieNoExpiry :: IO ()
testReceiveSetCookieNoExpiry = assertEqual "Expiry is based on max age"
  now_plus_diff_time (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie cookie_without_expiry default_request default_time True $ createCookieJar [])
  where now_plus_diff_time = ((fromRational $ toRational default_diff_time) `addUTCTime` default_time)
        cookie_without_expiry = default_set_cookie {setCookieExpires = Nothing}

testReceiveSetCookieNoExpiryNoMaxAge :: IO ()
testReceiveSetCookieNoExpiryNoMaxAge = assertBool "Expiry is set to a future date" $
  default_time < (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie basic_cookie default_request default_time True $ createCookieJar [])
  where basic_cookie = default_set_cookie { setCookieExpires = Nothing, setCookieMaxAge = Nothing }

testReceiveSetCookiePath :: IO ()
testReceiveSetCookiePath = assertEqual "Path gets set correctly"
  (fromString "/a/path") (cookie_path $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar [])
  where set_cookie = default_set_cookie {setCookiePath = Just $ fromString "/a/path"}

testReceiveSetCookieNoPath :: IO ()
testReceiveSetCookieNoPath = assertEqual "Path gets set correctly when nonexistent"
  (fromString "/a/path/to") (cookie_path $ head $ destroyCookieJar $ receiveSetCookie set_cookie request default_time True $ createCookieJar [])
  where set_cookie = default_set_cookie {setCookiePath = Nothing}
        request = default_request {HC.path = fromString "/a/path/to/nowhere"}

testReceiveSetCookieCreationTime :: IO ()
testReceiveSetCookieCreationTime = assertEqual "Creation time gets set correctly"
  now (cookie_creation_time $ head $ destroyCookieJar $ receiveSetCookie default_set_cookie default_request now True $ createCookieJar [])
  where now = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 1)

testReceiveSetCookieAccessTime :: IO ()
testReceiveSetCookieAccessTime = assertEqual "Last access time gets set correctly"
  now (cookie_last_access_time $ head $ destroyCookieJar $ receiveSetCookie default_set_cookie default_request now True $ createCookieJar [])
  where now = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 1)

testReceiveSetCookiePersistent :: IO ()
testReceiveSetCookiePersistent = assertBool "Persistent flag gets set correctly" $
  cookie_persistent $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar []
  where set_cookie = default_set_cookie {setCookieExpires = Just default_time}

testReceiveSetCookieSecure :: IO ()
testReceiveSetCookieSecure = assertBool "Secure flag gets set correctly" $
  cookie_secure_only $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar []
  where set_cookie = default_set_cookie {setCookieSecure = True}

testReceiveSetCookieMaxAge :: IO ()
testReceiveSetCookieMaxAge = assertEqual "Max-Age gets set correctly"
  total (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request now True $ createCookieJar [])
  where set_cookie = default_set_cookie { setCookieExpires = Nothing
                                        , setCookieMaxAge = Just $ secondsToDiffTime 10
                                        }
        now = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 12)
        total = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 22)

testReceiveSetCookiePreferMaxAge :: IO ()
testReceiveSetCookiePreferMaxAge = assertEqual "Max-Age is preferred over Expires"
  total (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request now True $ createCookieJar [])
  where set_cookie = default_set_cookie { setCookieExpires = Just exp
                                        , setCookieMaxAge = Just $ secondsToDiffTime 10
                                        }
        exp = UTCTime (ModifiedJulianDay 11) (secondsToDiffTime 5)
        now = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 12)
        total = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 22)

testReceiveSetCookieExisting :: IO ()
testReceiveSetCookieExisting = assertEqual "Existing cookie gets updated"
  t (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar [default_cookie])
  where set_cookie = default_set_cookie { setCookieExpires = Just t
                                        , setCookieMaxAge = Nothing
                                        }
        t = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 12)

testReceiveSetCookieExistingCreation :: IO ()
testReceiveSetCookieExistingCreation = assertEqual "Creation time gets updated in existing cookie"
  default_time (cookie_creation_time $ head $ destroyCookieJar $ receiveSetCookie default_set_cookie default_request now True $ createCookieJar [default_cookie])
  where now = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 12)

testReceiveSetCookieExistingHttpOnly :: IO ()
testReceiveSetCookieExistingHttpOnly = assertEqual "Existing http-only cookie gets dropped"
  default_time (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie default_set_cookie default_request default_time False $ createCookieJar [existing_cookie])
  where existing_cookie = default_cookie {cookie_http_only = True}

testMonoidPreferRecent :: IO ()
testMonoidPreferRecent = assertEqual "Monoid prefers more recent cookies"
  (cct $ createCookieJar [c2]) (cct $ createCookieJar [c1] `Data.Monoid.mappend` createCookieJar [c2])
  where c1 = default_cookie {cookie_creation_time = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 1)}
        c2 = default_cookie {cookie_creation_time = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 2)}
        cct cj = cookie_creation_time $ head $ destroyCookieJar cj

ipParseTests :: Spec
ipParseTests = do
    it "Valid IP" testValidIp
    it "Digit Too High" testIpNumTooHigh
    it "Too Many Segments" testTooManySegmentsInIp
    it "Chars in IP" testCharsInIp

domainMatchingTests :: Spec
domainMatchingTests = do
    it "Should Match" testDomainMatchesSuccess
    it "Same Domain" testSameDomain
    it "Sibling Domain" testSiblingDomain
    it "Parent Domain" testParentDomain
    it "Checking for Naive suffix-check" testNaiveSuffixDomain

defaultPathTests :: Spec
defaultPathTests = do
    it "Basic default path test" testDefaultPath
    it "Basic populated default path" testPopulatedDefaultPath
    it "Default path from request with GET params works" testParamsDefaultPath
    it "Getting a default path that ends in a slash" testDefaultPathEndingInSlash
    it "Getting a short default path" testShortDefaultPath

pathMatchingTests :: Spec
pathMatchingTests = do
    it "Same paths match" testSamePathsMatch
    it "Putting slash at end" testPathSlashAtEnd
    it "Not putting slash at end" testPathNoSlashAtEnd
    it "Diverging paths don't match" testDivergingPaths

equalityTests :: Spec
equalityTests = do
    it "The same cookie should be equal to itself" testCookieEqualitySuccess
    it "Changing extra options shouldn't change equality" testCookieEqualityResiliance
    it "Changing a cookie's domain should change its equality" testDomainChangesEquality

removeTests :: Spec
removeTests = do
    it "Removing a cookie works" testRemoveCookie
    it "Removing a nonexistent cookie doesn't work" testRemoveNonexistantCookie
    it "Removing the correct cookie" testRemoveCorrectCookie

evictionTests :: Spec
evictionTests = do
    it "Testing eviction" testEvictExpiredCookies
    it "Evicting from empty cookie jar" testEvictNoCookies

sendingTests :: Spec
sendingTests = do
    it "Updates last access time upon using cookies" testComputeCookieStringUpdateLastAccessTime
    it "Host-only flag matches exact host" testComputeCookieStringHostOnly
    it "Host-only flag doesn't match subdomain" testComputeCookieStringHostOnlyFilter
    it "Domain matching works properly" testComputeCookieStringDomainMatching
    it "Path matching works" testComputeCookieStringPathMatching
    it "Path matching fails when it should" testComputeCookieStringPathMatchingFails
    it "Path matching succeeds when request has GET params" testComputeCookieStringPathMatchingWithParms
    it "Secure flag filters correctly" testComputeCookieStringSecure
    it "Http-only flag filters correctly" testComputeCookieStringHttpOnly
    it "Sorting works correctly" testComputeCookieStringSort
    it "Inserting cookie header works" testInsertCookiesIntoRequestWorks

receivingTests :: Spec
receivingTests = do
    it "Can receive set-cookie" testReceiveSetCookie
    it "Receiving a Set-Cookie with a trailing dot on the domain" testReceiveSetCookieTrailingDot
    it "Receiving a Set-Cookie with a leading dot on the domain" testReceiveSetCookieLeadingDot
    it "Set-Cookie with no domain" testReceiveSetCookieNoDomain
    it "Set-Cookie with empty domain" testReceiveSetCookieEmptyDomain
    it "Set-Cookie with non-matching domain" testReceiveSetCookieNonMatchingDomain
    it "Host-only flag gets set" testReceiveSetCookieHostOnly
    it "Host-only flag doesn't get set" testReceiveSetCookieHostOnlyNotSet
    it "Http-only flag gets set" testReceiveSetCookieHttpOnly
    it "Http-only flag doesn't get set" testReceiveSetCookieHttpOnlyNotSet
    it "Checking non http request gets dropped" testReceiveSetCookieHttpOnlyDrop
    it "Name gets set correctly" testReceiveSetCookieName
    it "Value gets set correctly" testReceiveSetCookieValue
    it "Expiry gets set correctly" testReceiveSetCookieExpiry
    it "Expiry gets set based on max age if no expiry is given" testReceiveSetCookieNoExpiry
    it "Expiry gets set based on given value if no max age is given" testReceiveSetCookieNoMaxAge
    it "Expiry gets set to a future date if no expiry and no max age are given" testReceiveSetCookieNoExpiryNoMaxAge
    it "Path gets set correctly when nonexistent" testReceiveSetCookieNoPath
    it "Path gets set correctly" testReceiveSetCookiePath
    it "Creation time gets set correctly" testReceiveSetCookieCreationTime
    it "Last access time gets set correctly" testReceiveSetCookieAccessTime
    it "Persistent flag gets set correctly" testReceiveSetCookiePersistent
    it "Existing cookie gets updated" testReceiveSetCookieExisting
    it "Creation time gets updated in existing cookie" testReceiveSetCookieExistingCreation
    it "Existing http-only cookie gets dropped" testReceiveSetCookieExistingHttpOnly
    it "Secure flag gets set correctly" testReceiveSetCookieSecure
    it "Max-Age flag gets set correctly" testReceiveSetCookieMaxAge
    it "Max-Age is preferred over Expires" testReceiveSetCookiePreferMaxAge

monoidTests :: Spec
monoidTests = do
    it "Monoid prefers more recent cookies" testMonoidPreferRecent

cookieTest :: Spec
cookieTest = do
    describe "ipParseTests" ipParseTests
    describe "domainMatchingTests" domainMatchingTests
    describe "defaultPathTests" defaultPathTests
    describe "pathMatchingTests" pathMatchingTests
    describe "equalityTests" equalityTests
    describe "removeTests" removeTests
    describe "evictionTests" evictionTests
    describe "sendingTests" sendingTests
    describe "receivingTests" receivingTests
    describe "monoidTest" monoidTests