summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMichaelSnoyman <>2012-10-21 10:49:32 (GMT)
committerhdiff <hdiff@luite.com>2012-10-21 10:49:32 (GMT)
commitf0bcde63583e81e94d0aabedb9c3df2e031de6d0 (patch)
treef79a5ad650df02afd1b9a54f7885d791319b1dce
parente74ce03a38d8ed20207e63b9a14f6988654c4f45 (diff)
version 1.7.01.7.0
-rw-r--r--Network/HTTP/Conduit/Browser.hs266
-rw-r--r--http-conduit.cabal5
-rw-r--r--test/CookieTest.hs546
-rw-r--r--test/main.hs115
4 files changed, 548 insertions, 384 deletions
diff --git a/Network/HTTP/Conduit/Browser.hs b/Network/HTTP/Conduit/Browser.hs
deleted file mode 100644
index 25d8bc9..0000000
--- a/Network/HTTP/Conduit/Browser.hs
+++ /dev/null
@@ -1,266 +0,0 @@
-{-# LANGUAGE CPP #-}
--- | This module is designed to work similarly to the Network.Browser module in the HTTP package.
--- The idea is that there are two new types defined: 'BrowserState' and 'BrowserAction'. The
--- purpose of this module is to make it easy to describe a browsing session, including navigating
--- to multiple pages, and have things like cookie jar updates work as expected as you browse
--- around.
---
--- BrowserAction is a monad that handles all your browser-related activities. This monad is
--- actually implemented as a specialization of the State monad, over the BrowserState type. The
--- BrowserState type has various bits of information that a web browser keeps, such as a current
--- cookie jar, the number of times to retry a request on failure, HTTP proxy information, etc. In
--- the BrowserAction monad, there is one BrowserState at any given time, and you can modify it by
--- using the convenience functions in this module.
---
--- A special kind of modification of the current browser state is the action of making a HTTP
--- request. This will do the request according to the params in the current BrowserState, as well
--- as modifying the current state with, for example, an updated cookie jar.
---
--- To use this module, you would bind together a series of BrowserActions (This simulates the user
--- clicking on links or using a settings dialogue etc.) to describe your browsing session. When
--- you've described your session, you call 'browse' on your top-level BrowserAction to actually
--- convert your actions into the ResourceT IO monad.
---
--- Here is an example program:
---
--- > import qualified Data.ByteString as B
--- > import qualified Data.ByteString.Lazy as LB
--- > import qualified Data.ByteString.UTF8 as UB
--- > import Data.Conduit
--- > import Network.HTTP.Conduit
--- > import Network.HTTP.Conduit.Browser
--- >
--- > -- The web request to log in to a service
--- > req1 :: IO (Request (ResourceT IO))
--- > req1 = do
--- > req <- parseUrl "http://www.myurl.com/login.php"
--- > return $ urlEncodedBody [ (UB.fromString "name", UB.fromString "litherum")
--- > , (UB.fromString "pass", UB.fromString "S33kRe7")
--- > ] req
--- >
--- > -- Once authenticated, run this request
--- > req2 :: IO (Request m')
--- > req2 = parseUrl "http://www.myurl.com/main.php"
--- >
--- > -- Bind two BrowserActions together
--- > action :: Request (ResourceT IO) -> Request (ResourceT IO) -> BrowserAction (Response LB.ByteString)
--- > action r1 r2 = do
--- > _ <- makeRequestLbs r1
--- > makeRequestLbs r2
--- >
--- > main :: IO ()
--- > main = do
--- > man <- newManager def
--- > r1 <- req1
--- > r2 <- req2
--- > out <- runResourceT $ browse man $ action r1 r2
--- > putStrLn $ UB.toString $ B.concat $ LB.toChunks $ responseBody out
-
-module Network.HTTP.Conduit.Browser
- ( BrowserState
- , BrowserAction
- , browse
- , makeRequest
- , makeRequestLbs
- , defaultState
- , getBrowserState
- , setBrowserState
- , withBrowserState
- , getMaxRedirects
- , setMaxRedirects
- , getMaxRetryCount
- , setMaxRetryCount
- , getAuthorities
- , setAuthorities
- , getCookieFilter
- , setCookieFilter
- , getCookieJar
- , setCookieJar
- , getCurrentProxy
- , setCurrentProxy
- , getUserAgent
- , setUserAgent
- , getManager
- , setManager
- )
- where
-
-import qualified Data.ByteString as BS
-import qualified Data.ByteString.Lazy as L
-import Control.Monad.State
-import Control.Exception
-import qualified Control.Exception.Lifted as LE
-import Data.Conduit
-#if !MIN_VERSION_base(4,6,0)
-import Prelude hiding (catch)
-#endif
-import qualified Network.HTTP.Types as HT
-import Data.Time.Clock (getCurrentTime, UTCTime)
-import Data.CaseInsensitive (mk)
-import Data.ByteString.UTF8 (fromString)
-import Data.List (partition)
-import Web.Cookie (parseSetCookie)
-import Data.Default (def)
-import Data.Maybe (catMaybes)
-
-import Network.HTTP.Conduit.Cookies hiding (updateCookieJar)
-import Network.HTTP.Conduit.Request
-import Network.HTTP.Conduit.Response
-import Network.HTTP.Conduit.Manager
-import qualified Network.HTTP.Conduit as HC
-
-data BrowserState = BrowserState
- { maxRedirects :: Int
- , maxRetryCount :: Int
- , authorities :: Request (ResourceT IO) -> Maybe (BS.ByteString, BS.ByteString)
- , cookieFilter :: Request (ResourceT IO) -> Cookie -> IO Bool
- , cookieJar :: CookieJar
- , currentProxy :: Maybe Proxy
- , userAgent :: BS.ByteString
- , manager :: Manager
- }
-
-defaultState :: Manager -> BrowserState
-defaultState m = BrowserState { maxRedirects = 10
- , maxRetryCount = 1
- , authorities = \ _ -> Nothing
- , cookieFilter = \ _ _ -> return True
- , cookieJar = def
- , currentProxy = Nothing
- , userAgent = fromString "http-conduit"
- , manager = m
- }
-
-type BrowserAction = StateT BrowserState (ResourceT IO)
-
--- | Do the browser action with the given manager
-browse :: Manager -> BrowserAction a -> ResourceT IO a
-browse m act = evalStateT act (defaultState m)
-
--- | Make a request, using all the state in the current BrowserState
-makeRequest :: Request (ResourceT IO) -> BrowserAction (Response (ResumableSource (ResourceT IO) BS.ByteString))
-makeRequest request = do
- BrowserState
- { maxRetryCount = max_retry_count
- , currentProxy = current_proxy
- , userAgent = user_agent
- } <- get
- retryHelper (applyUserAgent user_agent $
- request { redirectCount = 0
- , proxy = current_proxy
- , checkStatus = \ _ _ -> Nothing
- }) max_retry_count Nothing
- where retryHelper request' retry_count e
- | retry_count == 0 = case e of
- Just e' -> throw e'
- Nothing -> throw TooManyRetries
- | otherwise = do
- BrowserState {maxRedirects = max_redirects} <- get
- resp <- LE.catch (if max_redirects==0
- then (\(_,a,_) -> a) `fmap` performRequest request'
- else runRedirectionChain request' max_redirects [])
- (\ e' -> retryHelper request' (retry_count - 1) (Just (e' :: HttpException)))
- let code = HT.statusCode $ HC.responseStatus resp
- if code < 200 || code >= 300
- then retryHelper request' (retry_count - 1) (Just $ HC.StatusCodeException (HC.responseStatus resp) (HC.responseHeaders resp))
- else return resp
- performRequest request' = do
- s@(BrowserState { manager = manager'
- , authorities = auths
- , cookieJar = cookie_jar
- , cookieFilter = cookie_filter
- }) <- get
- now <- liftIO getCurrentTime
- let (request'', cookie_jar') = insertCookiesIntoRequest
- (applyAuthorities auths request')
- (evictExpiredCookies cookie_jar now) now
- res <- lift $ HC.http request'' manager'
- (cookie_jar'', response) <- liftIO $ updateCookieJar res request'' now cookie_jar' cookie_filter
- put $ s {cookieJar = cookie_jar''}
- return (request'', res, response)
- runRedirectionChain request' redirect_count ress
- | redirect_count == (-1) = throw . TooManyRedirects =<< mapM (liftIO . runResourceT . lbsResponse) ress
- | otherwise = do
- (request'', res, response) <- performRequest request'
- let code = HT.statusCode (HC.responseStatus response)
- if code >= 300 && code < 400
- then do request''' <- case HC.getRedirectedRequest request'' (responseHeaders response) code of
- Just a -> return a
- Nothing -> throw . HC.UnparseableRedirect =<< (liftIO $ runResourceT $ lbsResponse response)
- runRedirectionChain request''' (redirect_count - 1) (res:ress)
- else return res
- applyAuthorities auths request' = case auths request' of
- Just (user, pass) -> applyBasicAuth user pass request'
- Nothing -> request'
- applyUserAgent ua request' = request' {requestHeaders = (k, ua) : hs}
- where hs = filter ((/= k) . fst) $ requestHeaders request'
- k = mk $ fromString "User-Agent"
-
-makeRequestLbs :: Request (ResourceT IO) -> BrowserAction (Response L.ByteString)
-makeRequestLbs = liftIO . runResourceT . lbsResponse <=< makeRequest
-
-updateCookieJar :: Response a -> Request (ResourceT IO) -> UTCTime -> CookieJar -> (Request (ResourceT IO) -> Cookie -> IO Bool) -> IO (CookieJar, Response a)
-updateCookieJar response request' now cookie_jar cookie_filter = do
- filtered_cookies <- filterM (cookie_filter request') $ catMaybes $ map (\ sc -> generateCookie sc request' now True) set_cookies
- return (cookieJar' filtered_cookies, response {HC.responseHeaders = other_headers})
- where (set_cookie_headers, other_headers) = partition ((== (mk $ fromString "Set-Cookie")) . fst) $ HC.responseHeaders response
- set_cookie_data = map snd set_cookie_headers
- set_cookies = map parseSetCookie set_cookie_data
- cookieJar' = foldl (\ cj c -> insertCheckedCookie c cj True) cookie_jar
-
--- | You can save and restore the state at will
-getBrowserState :: BrowserAction BrowserState
-getBrowserState = get
-setBrowserState :: BrowserState -> BrowserAction ()
-setBrowserState = put
-withBrowserState :: BrowserState -> BrowserAction a -> BrowserAction a
-withBrowserState s a = do
- current <- get
- put s
- out <- a
- put current
- return out
-
--- | The number of redirects to allow
-getMaxRedirects :: BrowserAction Int
-getMaxRedirects = get >>= \ a -> return $ maxRedirects a
-setMaxRedirects :: Int -> BrowserAction ()
-setMaxRedirects b = get >>= \ a -> put a {maxRedirects = b}
--- | The number of times to retry a failed connection
-getMaxRetryCount :: BrowserAction Int
-getMaxRetryCount = get >>= \ a -> return $ maxRetryCount a
-setMaxRetryCount :: Int -> BrowserAction ()
-setMaxRetryCount b = get >>= \ a -> put a {maxRetryCount = b}
--- | A user-provided function that provides optional authorities.
--- This function gets run on all requests before they get sent out.
--- The output of this function is applied to the request.
-getAuthorities :: BrowserAction (Request (ResourceT IO) -> Maybe (BS.ByteString, BS.ByteString))
-getAuthorities = get >>= \ a -> return $ authorities a
-setAuthorities :: (Request (ResourceT IO) -> Maybe (BS.ByteString, BS.ByteString)) -> BrowserAction ()
-setAuthorities b = get >>= \ a -> put a {authorities = b}
--- | Each new Set-Cookie the browser encounters will pass through this filter.
--- Only cookies that pass the filter (and are already valid) will be allowed into the cookie jar
-getCookieFilter :: BrowserAction (Request (ResourceT IO) -> Cookie -> IO Bool)
-getCookieFilter = get >>= \ a -> return $ cookieFilter a
-setCookieFilter :: (Request (ResourceT IO) -> Cookie -> IO Bool) -> BrowserAction ()
-setCookieFilter b = get >>= \ a -> put a {cookieFilter = b}
--- | All the cookies!
-getCookieJar :: BrowserAction CookieJar
-getCookieJar = get >>= \ a -> return $ cookieJar a
-setCookieJar :: CookieJar -> BrowserAction ()
-setCookieJar b = get >>= \ a -> put a {cookieJar = b}
--- | An optional proxy to send all requests through
-getCurrentProxy :: BrowserAction (Maybe Proxy)
-getCurrentProxy = get >>= \ a -> return $ currentProxy a
-setCurrentProxy :: Maybe Proxy -> BrowserAction ()
-setCurrentProxy b = get >>= \ a -> put a {currentProxy = b}
--- | What string to report our user-agent as
-getUserAgent :: BrowserAction BS.ByteString
-getUserAgent = get >>= \ a -> return $ userAgent a
-setUserAgent :: BS.ByteString -> BrowserAction ()
-setUserAgent b = get >>= \ a -> put a {userAgent = b}
--- | The active manager, managing the connection pool
-getManager :: BrowserAction Manager
-getManager = get >>= \ a -> return $ manager a
-setManager :: Manager -> BrowserAction ()
-setManager b = get >>= \ a -> put a {manager = b}
diff --git a/http-conduit.cabal b/http-conduit.cabal
index 6225a49..9a90edb 100644
--- a/http-conduit.cabal
+++ b/http-conduit.cabal
@@ -1,5 +1,5 @@
name: http-conduit
-version: 1.6.1.2
+version: 1.7.0
license: BSD3
license-file: LICENSE
author: Michael Snoyman <michael@snoyman.com>
@@ -12,7 +12,7 @@ stability: Stable
cabal-version: >= 1.8
build-type: Simple
homepage: http://www.yesodweb.com/book/http-conduit
-extra-source-files: test/main.hs
+extra-source-files: test/main.hs, test/CookieTest.hs
flag network-bytestring
default: False
@@ -57,7 +57,6 @@ library
else
build-depends: network >= 2.3
exposed-modules: Network.HTTP.Conduit
- Network.HTTP.Conduit.Browser
Network.HTTP.Conduit.Internal
other-modules: Network.HTTP.Conduit.Parser
Network.HTTP.Conduit.ConnInfo
diff --git a/test/CookieTest.hs b/test/CookieTest.hs
new file mode 100644
index 0000000..8da5baa
--- /dev/null
+++ b/test/CookieTest.hs
@@ -0,0 +1,546 @@
+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.Conduit.Cookies
+import qualified Network.HTTP.Conduit as HC
+import Data.ByteString.UTF8
+import Data.Maybe
+import Data.Time.Clock
+import Data.Time.Calendar
+import qualified Data.CaseInsensitive as CI
+import Web.Cookie
+
+default_request :: HC.Request m
+default_request = fromJust $ HC.parseUrl "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 :: Test
+testValidIp = TestCase $ assertBool "Couldn't parse valid IP address" $
+ isIpAddress $ fromString "1.2.3.4"
+
+testIpNumTooHigh :: Test
+testIpNumTooHigh = TestCase $ assertBool "One of the digits in the IP address is too large" $
+ not $ isIpAddress $ fromString "501.2.3.4"
+
+testTooManySegmentsInIp :: Test
+testTooManySegmentsInIp = TestCase $ assertBool "Too many segments in the ip address" $
+ not $ isIpAddress $ fromString "1.2.3.4.5"
+
+testCharsInIp :: Test
+testCharsInIp = TestCase $ assertBool "Chars are not allowed in IP addresses" $
+ not $ isIpAddress $ fromString "1.2a3.4.5"
+
+testDomainMatchesSuccess :: Test
+testDomainMatchesSuccess = TestCase $ assertBool "Domains should match" $
+ domainMatches (fromString "www.google.com") (fromString "google.com")
+
+testSameDomain :: Test
+testSameDomain = TestCase $ assertBool "Same domain should match" $
+ domainMatches domain domain
+ where domain = fromString "www.google.com"
+
+testSiblingDomain :: Test
+testSiblingDomain = TestCase $ assertBool "Sibling domain should not match" $
+ not $ domainMatches (fromString "www.google.com") (fromString "secure.google.com")
+
+testParentDomain :: Test
+testParentDomain = TestCase $ assertBool "Parent domain should fail" $
+ not $ domainMatches (fromString "google.com") (fromString "www.google.com")
+
+testNaiveSuffixDomain :: Test
+testNaiveSuffixDomain = TestCase $ assertBool "Naively checking for suffix for domain matching should fail" $
+ not $ domainMatches (fromString "agoogle.com") (fromString "google.com")
+
+testDefaultPath :: Test
+testDefaultPath = TestCase $ assertEqual "Getting default path from a request"
+ (fromString "/") (defaultPath default_request)
+
+testShortDefaultPath :: Test
+testShortDefaultPath = TestCase $ assertEqual "Getting default path from a short path"
+ (fromString "/") (defaultPath $ default_request {HC.path = fromString "/search"})
+
+testPopulatedDefaultPath :: Test
+testPopulatedDefaultPath = TestCase $ assertEqual "Getting default path from a request with a path"
+ (fromString "/search") (defaultPath $ default_request {HC.path = fromString "/search/term"})
+
+testParamsDefaultPath :: Test
+testParamsDefaultPath = TestCase $ 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 :: Test
+testDefaultPathEndingInSlash = TestCase $ assertEqual "Getting default path that ends in a slash"
+ (fromString "/search/term") (defaultPath $ default_request {HC.path = fromString "/search/term/"})
+
+testSamePathsMatch :: Test
+testSamePathsMatch = TestCase $ assertBool "The same path should match" $
+ pathMatches path path
+ where path = fromString "/a/path"
+
+testPathSlashAtEnd :: Test
+testPathSlashAtEnd = TestCase $ assertBool "Putting the slash at the end should still match paths" $
+ pathMatches (fromString "/a/path/to/here") (fromString "/a/path/")
+
+testPathNoSlashAtEnd :: Test
+testPathNoSlashAtEnd = TestCase $ assertBool "Not putting the slash at the end should still match paths" $
+ pathMatches (fromString "/a/path/to/here") (fromString "/a/path")
+
+testDivergingPaths :: Test
+testDivergingPaths = TestCase $ assertBool "Diverging paths don't match" $
+ not $ pathMatches (fromString "/a/path/to/here") (fromString "/a/different/path")
+
+testCookieEqualitySuccess :: Test
+testCookieEqualitySuccess = TestCase $ assertEqual "The same cookies should be equal"
+ cookie cookie
+ where cookie = default_cookie
+
+testCookieEqualityResiliance :: Test
+testCookieEqualityResiliance = TestCase $ assertEqual "Cookies should still be equal if extra options are changed"
+ (default_cookie {cookie_persistent = True}) (default_cookie {cookie_host_only = True})
+
+testDomainChangesEquality :: Test
+testDomainChangesEquality = TestCase $ assertBool "Changing the domain should make cookies not equal" $
+ default_cookie /= (default_cookie {cookie_domain = fromString "/search"})
+
+testRemoveCookie :: Test
+testRemoveCookie = TestCase $ assertEqual "Removing a cookie works"
+ (Just default_cookie, createCookieJar []) (removeExistingCookieFromCookieJar default_cookie $ createCookieJar [default_cookie])
+
+testRemoveNonexistantCookie :: Test
+testRemoveNonexistantCookie = TestCase $ assertEqual "Removing a nonexistant cookie doesn't work"
+ (Nothing, createCookieJar [default_cookie]) (removeExistingCookieFromCookieJar (default_cookie {cookie_name = fromString "key2"}) $ createCookieJar [default_cookie])
+
+testRemoveCorrectCookie :: Test
+testRemoveCorrectCookie = TestCase $ 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 :: Test
+testEvictExpiredCookies = TestCase $ 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 :: Test
+testEvictNoCookies = TestCase $ assertEqual "Evicting empty cookie jar"
+ (createCookieJar []) (evictExpiredCookies (createCookieJar []) middle)
+ where middle = UTCTime (ModifiedJulianDay 2) (secondsToDiffTime 0)
+
+testComputeCookieStringUpdateLastAccessTime :: Test
+testComputeCookieStringUpdateLastAccessTime = TestCase $ 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 :: Test
+testComputeCookieStringHostOnly = TestCase $ 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 :: Test
+testComputeCookieStringHostOnlyFilter = TestCase $ 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 :: Test
+testComputeCookieStringDomainMatching = TestCase $ 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 :: Test
+testComputeCookieStringPathMatching = TestCase $ 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 :: Test
+testComputeCookieStringPathMatchingFails = TestCase $ 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 :: Test
+testComputeCookieStringPathMatchingWithParms = TestCase $ 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 :: Test
+testComputeCookieStringSecure = TestCase $ 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 :: Test
+testComputeCookieStringHttpOnly = TestCase $ 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 :: Test
+testComputeCookieStringSort = TestCase $ 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 :: Test
+testInsertCookiesIntoRequestWorks = TestCase $ 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 :: Test
+testReceiveSetCookie = TestCase $ assertEqual "Receiving a Set-Cookie"
+ (createCookieJar [default_cookie]) (receiveSetCookie default_set_cookie default_request default_time True $ createCookieJar [])
+
+testReceiveSetCookieTrailingDot :: Test
+testReceiveSetCookieTrailingDot = TestCase $ 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 :: Test
+testReceiveSetCookieLeadingDot = TestCase $ 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 :: Test
+testReceiveSetCookieNoDomain = TestCase $ 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 :: Test
+testReceiveSetCookieEmptyDomain = TestCase $ 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 :: Test
+testReceiveSetCookieNonMatchingDomain = TestCase $ 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 :: Test
+testReceiveSetCookieHostOnly = TestCase $ 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 :: Test
+testReceiveSetCookieHostOnlyNotSet = TestCase $ 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 :: Test
+testReceiveSetCookieHttpOnly = TestCase $ 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 :: Test
+testReceiveSetCookieHttpOnlyNotSet = TestCase $ 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 :: Test
+testReceiveSetCookieHttpOnlyDrop = TestCase $ 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 :: Test
+testReceiveSetCookieName = TestCase $ assertEqual "Name gets set correctly"
+ (fromString "name") (cookie_name $ head $ destroyCookieJar $ receiveSetCookie default_set_cookie default_request default_time True $ createCookieJar [])
+
+testReceiveSetCookieValue :: Test
+testReceiveSetCookieValue = TestCase $ assertEqual "Value gets set correctly"
+ (fromString "value") (cookie_value $ head $ destroyCookieJar $ receiveSetCookie default_set_cookie default_request default_time True $ createCookieJar [])
+
+testReceiveSetCookieExpiry :: Test
+testReceiveSetCookieExpiry = TestCase $ 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 :: Test
+testReceiveSetCookieNoMaxAge = TestCase $ 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 :: Test
+testReceiveSetCookieNoExpiry = TestCase $ 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 :: Test
+testReceiveSetCookieNoExpiryNoMaxAge = TestCase $ 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 :: Test
+testReceiveSetCookiePath = TestCase $ 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 :: Test
+testReceiveSetCookieNoPath = TestCase $ assertEqual "Path gets set correctly when nonexistant"
+ (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 :: Test
+testReceiveSetCookieCreationTime = TestCase $ 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 :: Test
+testReceiveSetCookieAccessTime = TestCase $ 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 :: Test
+testReceiveSetCookiePersistent = TestCase $ 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 :: Test
+testReceiveSetCookieSecure = TestCase $ 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 :: Test
+testReceiveSetCookieMaxAge = TestCase $ 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 :: Test
+testReceiveSetCookiePreferMaxAge = TestCase $ 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 :: Test
+testReceiveSetCookieExisting = TestCase $ 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 :: Test
+testReceiveSetCookieExistingCreation = TestCase $ 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 :: Test
+testReceiveSetCookieExistingHttpOnly = TestCase $ 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}
+
+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 nonexistant 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 nonexistant" 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
+
+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
diff --git a/test/main.hs b/test/main.hs
index 9a49af5..5eb8e3b 100644
--- a/test/main.hs
+++ b/test/main.hs
@@ -8,7 +8,6 @@ import Network.Wai hiding (requestBody)
import qualified Network.Wai
import Network.Wai.Handler.Warp (run)
import Network.HTTP.Conduit
-import Network.HTTP.Conduit.Browser
import Data.ByteString.Base64 (encode)
import Control.Concurrent (forkIO, killThread, threadDelay)
import Network.HTTP.Types
@@ -28,40 +27,14 @@ import qualified Data.Text.Encoding as TE
import qualified Data.ByteString.Lazy as L
import Blaze.ByteString.Builder (fromByteString)
-strictToLazy :: S.ByteString -> L.ByteString
-strictToLazy = L.fromChunks . replicate 1
-
-lazyToStrict :: L.ByteString -> S.ByteString
-lazyToStrict = S.concat . L.toChunks
-
-dummy :: S.ByteString
-dummy = "dummy"
-
-user :: S.ByteString
-user = "user"
-
-pass :: S.ByteString
-pass = "pass"
-
app :: Application
app req =
case pathInfo req of
[] -> return $ responseLBS status200 [] "homepage"
["cookies"] -> return $ responseLBS status200 [tastyCookie] "cookies"
- ["print-cookies"] -> return $ responseLBS status200 [] $ getHeader "Cookie"
- ["useragent"] -> return $ responseLBS status200 [] $ getHeader "User-Agent"
- ["authorities"] -> return $ responseLBS status200 [] $ getHeader "Authorization"
- ["redir1"] -> return $ responseLBS temporaryRedirect307 [redir2] L.empty
- ["redir2"] -> return $ responseLBS temporaryRedirect307 [redir3] L.empty
- ["redir3"] -> return $ responseLBS status200 [] $ strictToLazy dummy
_ -> return $ responseLBS status404 [] "not found"
where tastyCookie = (mk (fromString "Set-Cookie"), fromString "flavor=chocolate-chip;")
- getHeader s = strictToLazy $ case lookup s $ Network.Wai.requestHeaders req of
- Just a -> a
- Nothing -> S.empty
- redir2 = (mk (fromString "Location"), fromString "/redir2")
- redir3 = (mk (fromString "Location"), fromString "/redir3")
main :: IO ()
main = hspec $ do
@@ -79,94 +52,6 @@ main = hspec $ do
case elbs of
Left (_ :: SomeException) -> return ()
Right _ -> error "Expected an exception"
- describe "browser" $ do
- it "cookie jar works" $ do
- tid <- forkIO $ run 3011 app
- request1 <- parseUrl "http://127.0.0.1:3011/cookies"
- request2 <- parseUrl "http://127.0.0.1:3011/print-cookies"
- elbs <- withManager $ \manager -> do
- browse manager $ do
- _ <- makeRequestLbs request1
- makeRequestLbs request2
- killThread tid
- if (lazyToStrict $ responseBody elbs) /= fromString "flavor=chocolate-chip"
- then error "Should have gotten the cookie back!"
- else return ()
- it "cookie filter can deny cookies" $ do
- tid <- forkIO $ run 3011 app
- request1 <- parseUrl "http://127.0.0.1:3011/cookies"
- request2 <- parseUrl "http://127.0.0.1:3011/print-cookies"
- elbs <- withManager $ \manager -> do
- browse manager $ do
- setCookieFilter $ const $ const $ return False
- _ <- makeRequestLbs request1
- makeRequestLbs request2
- killThread tid
- if (lazyToStrict $ responseBody elbs) /= S.empty
- then error "Shouldn't have gotten the cookie back!"
- else return ()
- it "can save and load cookie jar" $ do
- tid <- forkIO $ run 3011 app
- request1 <- parseUrl "http://127.0.0.1:3011/cookies"
- request2 <- parseUrl "http://127.0.0.1:3011/print-cookies"
- (elbs1, elbs2) <- withManager $ \manager -> do
- browse manager $ do
- _ <- makeRequestLbs request1
- cookie_jar <- getCookieJar
- setCookieJar def
- elbs1 <- makeRequestLbs request2
- setCookieJar cookie_jar
- elbs2 <- makeRequestLbs request2
- return (elbs1, elbs2)
- killThread tid
- if (((lazyToStrict $ responseBody elbs1) /= S.empty) ||
- ((lazyToStrict $ responseBody elbs2) /= fromString "flavor=chocolate-chip"))
- then error "Cookie jar got garbled up!"
- else return ()
- it "user agent sets correctly" $ do
- tid <- forkIO $ run 3012 app
- request <- parseUrl "http://127.0.0.1:3012/useragent"
- elbs <- withManager $ \manager -> do
- browse manager $ do
- setUserAgent $ fromString "abcd"
- makeRequestLbs request
- killThread tid
- if (lazyToStrict $ responseBody elbs) /= fromString "abcd"
- then error "Should have gotten the user agent back!"
- else return ()
- it "authorities get set correctly" $ do
- tid <- forkIO $ run 3013 app
- request <- parseUrl "http://127.0.0.1:3013/authorities"
- elbs <- withManager $ \manager -> do
- browse manager $ do
- setAuthorities $ const $ Just (user, pass)
- makeRequestLbs request
- killThread tid
- if (lazyToStrict $ responseBody elbs) /= (fromString "Basic " `S.append` (encode $ user `S.append` ":" `S.append` pass))
- then error "Authorities didn't get set correctly!"
- else return ()
- it "can follow redirects" $ do
- tid <- forkIO $ run 3014 app
- request <- parseUrl "http://127.0.0.1:3014/redir1"
- elbs <- withManager $ \manager -> do
- browse manager $ do
- setMaxRedirects 2
- makeRequestLbs request
- killThread tid
- if (lazyToStrict $ responseBody elbs) /= dummy
- then error "Should be able to follow 2 redirects"
- else return ()
- it "max redirects fails correctly" $ do
- tid <- forkIO $ run 3015 app
- request <- parseUrl "http://127.0.0.1:3015/redir1"
- elbs <- try $ withManager $ \manager -> do
- browse manager $ do
- setMaxRedirects 1
- makeRequestLbs request
- killThread tid
- case elbs of
- Left (TooManyRedirects _) -> return ()
- _ -> error "Shouldn't have followed all those redirects!"
describe "httpLbs" $ do
it "preserves 'set-cookie' headers" $ do
tid <- forkIO $ run 3010 app