diff --git a/Network/HTTP/Conduit/Browser.hs b/Network/HTTP/Conduit/Browser.hs deleted file mode 100644 --- 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 --- 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 @@ -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 diff --git a/test/CookieTest.hs b/test/CookieTest.hs new file mode 100644 --- /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 --- a/test/main.hs +++ b/test/main.hs @@ -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