http-conduit-2.3.7.3/test/CookieTest.hs

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