http-conduit 1.6.1.2 → 1.7.0
raw patch · 4 files changed
+548/−384 lines, 4 files
Files
- Network/HTTP/Conduit/Browser.hs +0/−266
- http-conduit.cabal +2/−3
- test/CookieTest.hs +546/−0
- test/main.hs +0/−115
− Network/HTTP/Conduit/Browser.hs
@@ -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}
http-conduit.cabal view
@@ -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 @@ 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 @@ 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
+ test/CookieTest.hs view
@@ -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
test/main.hs view
@@ -8,7 +8,6 @@ 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.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 @@ 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