http-conduit 1.8.9 → 1.9.0
raw patch · 11 files changed
+388/−311 lines, 11 filesdep +publicsuffixlistdep −attoparsecdep −attoparsec-conduitdep ~cprng-aes
Dependencies added: publicsuffixlist
Dependencies removed: attoparsec, attoparsec-conduit
Dependency ranges changed: cprng-aes
Files
- Network/HTTP/Conduit.hs +71/−46
- Network/HTTP/Conduit/Cookies.hs +11/−48
- Network/HTTP/Conduit/Internal.hs +46/−4
- Network/HTTP/Conduit/Manager.hs +12/−9
- Network/HTTP/Conduit/Parser.hs +64/−99
- Network/HTTP/Conduit/Request.hs +3/−2
- Network/HTTP/Conduit/Response.hs +27/−85
- Network/HTTP/Conduit/Types.hs +75/−4
- http-conduit.cabal +5/−7
- test/CookieTest.hs +16/−2
- test/main.hs +58/−5
Network/HTTP/Conduit.hs view
@@ -29,7 +29,10 @@ -- The following headers are automatically set by this module, and should not -- be added to 'requestHeaders': --+-- * Cookie+-- -- * Content-Length+-- -- * Transfer-Encoding -- -- Note: In previous versions, the Host header would be set by this module in@@ -38,6 +41,42 @@ -- have generated. This can be useful for calling a server which utilizes -- virtual hosting. --+-- Use `cookieJar` If you want to supply cookies with your request:+--+-- > {-# LANGUAGE OverloadedStrings #-}+-- > import Network.HTTP.Conduit+-- > import Network+-- > import Data.Time.Clock+-- > import Data.Time.Calendar+-- > import qualified Control.Exception as E+-- >+-- > past :: UTCTime+-- > past = UTCTime (ModifiedJulianDay 56200) (secondsToDiffTime 0)+-- >+-- > future :: UTCTime+-- > future = UTCTime (ModifiedJulianDay 562000) (secondsToDiffTime 0)+-- >+-- > cookie :: Cookie+-- > cookie = Cookie { cookie_name = "password_hash"+-- > , cookie_value = "abf472c35f8297fbcabf2911230001234fd2"+-- > , cookie_expiry_time = future+-- > , cookie_domain = "example.com"+-- > , cookie_path = "/"+-- > , cookie_creation_time = past+-- > , cookie_last_access_time = past+-- > , cookie_persistent = False+-- > , cookie_host_only = False+-- > , cookie_secure_only = False+-- > , cookie_http_only = False+-- > }+-- >+-- > main = withSocketsDo $ do+-- > request' <- parseUrl "http://example.com/secret-page"+-- > let request = request' { cookieJar = Just $ createCookieJar [cookie] }+-- > E.catch (withManager $ httpLbs request)+-- > (\(StatusCodeException s _ _) ->+-- > if statusCode==403 then putStrLn "login failed" else return ())+-- -- Any network code on Windows requires some initialization, and the network -- library provides withSocketsDo to perform it. Therefore, proper usage of -- this library will always involve calling that function at some point. The@@ -76,7 +115,6 @@ -- * Datatypes , Proxy (..) , RequestBody (..)- , Response (..) -- ** Request , Request , def@@ -97,7 +135,15 @@ , redirectCount , checkStatus , responseTimeout+ , cookieJar , getConnectionWrapper+ -- * Response+ , Response+ , responseStatus+ , responseVersion+ , responseHeaders+ , responseBody+ , responseCookieJar -- * Manager , Manager , newManager@@ -116,13 +162,6 @@ , CookieJar , createCookieJar , destroyCookieJar- , updateCookieJar- , receiveSetCookie- , generateCookie- , insertCheckedCookie- , insertCookiesIntoRequest- , computeCookieString- , evictExpiredCookies -- * Utility functions , parseUrl , applyBasicAuth@@ -150,19 +189,13 @@ import qualified Network.HTTP.Types as W import Data.Default (def) -import Control.Exception.Lifted (throwIO, handle)+import Control.Exception.Lifted (throwIO, try, IOException, handle) import Control.Monad ((<=<)) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Trans.Resource-import Control.Monad.Trans.State (get, put, evalStateT)-import Control.Monad.Trans (lift) -import Control.Exception (fromException, toException) import qualified Data.Conduit as C-import qualified Data.Conduit.Binary as CB-import qualified Data.Conduit.Internal as CI import Data.Conduit.Blaze (builderToByteString)-import Control.Exception.Lifted (try, IOException) import Data.Time.Clock @@ -171,7 +204,8 @@ import Network.HTTP.Conduit.Manager import Network.HTTP.Conduit.ConnInfo import Network.HTTP.Conduit.Cookies-import Network.HTTP.Conduit.Internal (httpRedirect)+import Network.HTTP.Conduit.Internal (httpRedirect, applyCheckStatus)+import Network.HTTP.Conduit.Types -- | The most low-level function for initiating an HTTP request. --@@ -225,39 +259,20 @@ -> Manager -> m (Response (C.ResumableSource m S.ByteString)) http req0 manager = wrapIOException $ do- res@(Response status _version hs body) <-+ res <- if redirectCount req0 == 0 then httpRaw req0 manager- else go (redirectCount req0) req0 def- case checkStatus req0 status hs of- Nothing -> return res- Just exc -> do- exc' <-- case fromException exc of- Just (StatusCodeException s hdrs) -> do- lbs <- body C.$$+- CB.take 1024- return $ toException $ StatusCodeException s $ hdrs ++- [("X-Response-Body-Start", S.concat $ L.toChunks lbs)]- _ -> do- let CI.ResumableSource _ final = body- final- return exc- liftIO $ throwIO exc'+ else go (redirectCount req0) req0+ maybe (return res) throwIO =<< applyCheckStatus (checkStatus req0) res where- go count req''' cookie_jar''' = (`evalStateT` cookie_jar''') $- httpRedirect+ go count req' = httpRedirect count- (\req'' -> do- cookie_jar'' <- get- now <- liftIO getCurrentTime- let (req', cookie_jar') = insertCookiesIntoRequest req'' (evictExpiredCookies cookie_jar'' now) now- res <- lift $ httpRaw req' manager- let (cookie_jar, _) = updateCookieJar res req' now cookie_jar'- put cookie_jar- let mreq = getRedirectedRequest req' (responseHeaders res) (W.statusCode (responseStatus res))+ (\req -> do+ res <- httpRaw req manager+ let mreq = getRedirectedRequest req (responseHeaders res) (responseCookieJar res) (W.statusCode (responseStatus res)) return (res, mreq))- lift- req'''+ id+ req' -- | Get a 'Response' without any redirect following. httpRaw@@ -265,7 +280,12 @@ => Request m -> Manager -> m (Response (C.ResumableSource m S.ByteString))-httpRaw req m = do+httpRaw req' m = do+ (req, cookie_jar') <- case cookieJar req' of+ Just cj -> do+ now <- liftIO getCurrentTime+ return $ insertCookiesIntoRequest req' (evictExpiredCookies cj now) now+ Nothing -> return (req', def) (timeout', (connRelease, ci, isManaged)) <- getConnectionWrapper req (responseTimeout req)@@ -290,7 +310,12 @@ (Left e, Fresh) -> liftIO $ throwIO e -- Everything went ok, so the connection is good. If any exceptions get -- thrown in the response body, just throw them as normal.- (Right x, _) -> return x+ (Right res, _) -> case cookieJar req' of+ Just _ -> do+ now' <- liftIO getCurrentTime+ let (cookie_jar, _) = updateCookieJar res req now' cookie_jar'+ return $ res {responseCookieJar = cookie_jar}+ Nothing -> return res where try' :: MonadBaseControl IO m => m a -> m (Either IOException a) try' = try
Network/HTTP/Conduit/Cookies.hs view
@@ -12,10 +12,13 @@ import Web.Cookie import qualified Data.CaseInsensitive as CI import Blaze.ByteString.Builder-import Data.Default+import qualified Network.PublicSuffixList.Lookup as PSL+import Data.Text.Encoding (decodeUtf8With)+import Data.Text.Encoding.Error (lenientDecode) import qualified Network.HTTP.Conduit.Request as Req import qualified Network.HTTP.Conduit.Response as Res+import Network.HTTP.Conduit.Types slash :: Integral a => a slash = 47 -- '/'@@ -54,56 +57,15 @@ -- in section 5.1.4 pathMatches :: BS.ByteString -> BS.ByteString -> Bool pathMatches requestPath cookiePath- | cookiePath == path = True- | cookiePath `BS.isPrefixOf` path && BS.singleton (BS.last cookiePath) == U.fromString "/" = True- | cookiePath `BS.isPrefixOf` path && BS.singleton (BS.head remainder) == U.fromString "/" = True+ | cookiePath == path' = True+ | cookiePath `BS.isPrefixOf` path' && BS.singleton (BS.last cookiePath) == U.fromString "/" = True+ | cookiePath `BS.isPrefixOf` path' && BS.singleton (BS.head remainder) == U.fromString "/" = True | otherwise = False where remainder = BS.drop (BS.length cookiePath) requestPath- path = case S8.uncons requestPath of+ path' = case S8.uncons requestPath of Just ('/', _) -> requestPath _ -> '/' `S8.cons` requestPath ---- This corresponds to the description of a cookie detailed in Section 5.3 \"Storage Model\"-data Cookie = Cookie- { cookie_name :: BS.ByteString- , cookie_value :: BS.ByteString- , cookie_expiry_time :: UTCTime- , cookie_domain :: BS.ByteString- , cookie_path :: BS.ByteString- , cookie_creation_time :: UTCTime- , cookie_last_access_time :: UTCTime- , cookie_persistent :: Bool- , cookie_host_only :: Bool- , cookie_secure_only :: Bool- , cookie_http_only :: Bool- }- deriving (Show)--- This corresponds to step 11 of the algorithm described in Section 5.3 \"Storage Model\"-instance Eq Cookie where- (==) a b = name_matches && domain_matches && path_matches- where name_matches = cookie_name a == cookie_name b- domain_matches = cookie_domain a == cookie_domain b- path_matches = cookie_path a == cookie_path b-instance Ord Cookie where- compare c1 c2- | BS.length (cookie_path c1) > BS.length (cookie_path c2) = LT- | BS.length (cookie_path c1) < BS.length (cookie_path c2) = GT- | cookie_creation_time c1 > cookie_creation_time c2 = GT- | otherwise = LT--newtype CookieJar = CJ { expose :: [Cookie] }---- | empty cookie jar-instance Default CookieJar where- def = CJ []--instance Eq CookieJar where- (==) cj1 cj2 = (L.sort $ expose cj1) == (L.sort $ expose cj2)--instance Show CookieJar where- show = show . expose- createCookieJar :: [Cookie] -> CookieJar createCookieJar = CJ @@ -128,7 +90,7 @@ rejectPublicSuffixes = True isPublicSuffix :: BS.ByteString -> Bool-isPublicSuffix _ = False+isPublicSuffix = PSL.isSuffix . decodeUtf8With lenientDecode -- | This corresponds to the eviction algorithm described in Section 5.3 \"Storage Model\" evictExpiredCookies :: CookieJar -- ^ Input cookie jar@@ -252,7 +214,8 @@ | firstCondition && domain' == (Req.host request) = return BS.empty | firstCondition = Nothing | otherwise = return domain'- where firstCondition = rejectPublicSuffixes && isPublicSuffix domain'+ where firstCondition = rejectPublicSuffixes && has_a_character && isPublicSuffix domain'+ has_a_character = not (BS.null domain') step6 domain' | firstCondition && not (domainMatches (Req.host request) domain') = Nothing | firstCondition = return (domain', False)
Network/HTTP/Conduit/Internal.hs view
@@ -1,28 +1,42 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE CPP #-} module Network.HTTP.Conduit.Internal- ( module Network.HTTP.Conduit.Parser- , getUri+ ( getUri , setUri , setUriRelative+ -- * Redirect loop , httpRedirect+ , applyCheckStatus+ -- * Cookie functions+ , updateCookieJar+ , receiveSetCookie+ , generateCookie+ , insertCheckedCookie+ , insertCookiesIntoRequest+ , computeCookieString+ , evictExpiredCookies ) where -import Network.HTTP.Conduit.Parser- import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Char8 as S8 +import Control.Exception (SomeException, toException, fromException) import Control.Exception.Lifted (throwIO) import Control.Monad.Trans.Resource import qualified Data.Conduit as C import qualified Data.Conduit.Binary as CB+import qualified Data.Conduit.Internal as CI import Data.Conduit.List (sinkNull) import Network.HTTP.Conduit.Request import Network.HTTP.Conduit.Response+import Network.HTTP.Conduit.Cookies+import Network.HTTP.Conduit.Types+import Network.HTTP.Types -- | Redirect loop httpRedirect@@ -57,3 +71,31 @@ -- And now perform the actual redirect go (count - 1) req (res:ress) Nothing -> return res++-- | Apply 'Request'\'s 'checkStatus' and return resulting exception if any.+applyCheckStatus+ :: (MonadResource m, MonadBaseControl IO m)+ => (Status -> ResponseHeaders -> CookieJar -> Maybe SomeException)+ -> Response (C.ResumableSource m S.ByteString)+ -> m (Maybe SomeException)+applyCheckStatus checkStatus' res =+ case checkStatus' (responseStatus res) (responseHeaders res) (responseCookieJar res) of+ Nothing -> return Nothing+ Just exc -> do+ exc' <-+ case fromException exc of+ Just (StatusCodeException s hdrs cookie_jar) -> do+ lbs <- (responseBody res) C.$$+- CB.take 1024+ return $ toException $ StatusCodeException s (hdrs +++ [("X-Response-Body-Start", toStrict' lbs)]) cookie_jar+ _ -> do+ let CI.ResumableSource _ final = (responseBody res)+ final+ return exc+ return (Just exc')+ where+#if MIN_VERSION_bytestring(0,10,0)+ toStrict' = L.toStrict+#else+ toStrict' = S.concat . L.toChunks+#endif
Network/HTTP/Conduit/Manager.hs view
@@ -38,7 +38,7 @@ import Control.Monad.Trans.Control (MonadBaseControl) import Control.Monad.IO.Class (MonadIO, liftIO)-import Control.Exception (mask_, SomeException, catch)+import Control.Exception (mask_, SomeException, catch, throwIO, fromException) import Control.Monad.Trans.Resource ( ResourceT, runResourceT, MonadResource , MonadThrow, MonadUnsafeIO@@ -59,11 +59,12 @@ import Network.HTTP.Conduit.ConnInfo import Network.HTTP.Conduit.Types import Network.HTTP.Conduit.Util (hGetSome)-import Network.HTTP.Conduit.Parser (parserHeadersFromByteString)+import Network.HTTP.Conduit.Parser (sinkHeaders) import Network.Socks5 (SocksConf) import Data.Default import Data.Maybe (mapMaybe) import System.IO (Handle)+import Data.Conduit (($$), yield, runException) -- | Settings for a @Manager@. Please use the 'def' function and then modify -- individual settings.@@ -344,20 +345,22 @@ L.hPutStr h $ Blaze.toLazyByteString connectRequest hFlush h r <- hGetSome h 2048- res <- parserHeadersFromByteString r- case res of+ case runException $ yield r $$ sinkHeaders of Right ((_, 200, _), _) -> return h- Right ((_, _, msg), _) -> hClose h >> proxyError (S8.unpack msg)- Left s -> hClose h >> proxyError s+ Right ((_, _, msg), _) -> hClose h >> proxyError (Left msg)+ Left s -> do+ hClose h+ proxyError $+ case fromException s of+ Just he -> Right he+ Nothing -> Left $ S8.pack $ show s connectRequest = Blaze.fromByteString "CONNECT " `mappend` Blaze.fromByteString thost `mappend` Blaze.fromByteString (S8.pack (':' : show tport)) `mappend` Blaze.fromByteString " HTTP/1.1\r\n\r\n"- proxyError s =- error $ "Proxy failed to CONNECT to '"- ++ S8.unpack thost ++ ":" ++ show tport ++ "' : " ++ s+ proxyError s = throwIO $ ProxyConnectException thost tport s -- | This function needs to acquire a @ConnInfo@- either from the @Manager@ or -- via I\/O, and register it with the @ResourceT@ so it is guaranteed to be
Network/HTTP/Conduit/Parser.hs view
@@ -2,122 +2,87 @@ {-# LANGUAGE FlexibleContexts #-} module Network.HTTP.Conduit.Parser ( sinkHeaders- , newline- , parserHeadersFromByteString- , parseChunkHeader ) where import Prelude hiding (take, takeWhile) import Control.Applicative-import Data.Word (Word8) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 -import Data.Attoparsec--import Data.Conduit.Attoparsec (sinkParser)-import Data.Conduit (Sink, MonadResource, MonadThrow)-import Control.Monad (when)+import Data.Conduit (Sink, MonadThrow (monadThrow), (=$))+import Control.Monad (when, unless)+import Network.HTTP.Conduit.Types (HttpException (..))+import qualified Data.Conduit.Binary as CB+import qualified Data.Conduit.List as CL type Header = (S.ByteString, S.ByteString)--parseHeader :: Parser Header-parseHeader = do- k <- takeWhile1 notNewlineColon- _ <- word8 58 -- colon- skipWhile isSpace- v <- takeWhile notNewline- newline- return (k, v)--notNewlineColon, isSpace, isNumber, notNewline :: Word8 -> Bool--notNewlineColon 10 = False -- LF-notNewlineColon 13 = False -- CR-notNewlineColon 58 = False -- colon-notNewlineColon _ = True--isSpace 32 = True-isSpace _ = False--isNumber i = 0x30 <= i && i <= 0x39--notNewline 10 = False-notNewline 13 = False-notNewline _ = True+type Status = (S.ByteString, Int, S.ByteString) -newline :: Parser ()-newline =- lf <|> (cr >> lf)+-- | New version of @sinkHeaders@ that doesn't use attoparsec. Should create+-- more meaningful exceptions.+--+-- Since 1.8.7+sinkHeaders :: (MonadThrow m) => Sink S.ByteString m (Status, [Header])+sinkHeaders = do+ status <- getStatusLine+ headers <- parseHeaders id+ return (status, headers) where- word8' x = word8 x >> return ()- lf = word8' 10- cr = word8' 13--parseHeaders :: Parser (Status, [Header])-parseHeaders = do- s <- parseStatus <?> "HTTP status line"- h <- manyTill parseHeader newline <?> "Response headers"- return (s, h)--sinkHeaders :: (MonadThrow m, MonadResource m) => Sink S.ByteString m (Status, [Header])-sinkHeaders = sinkParser parseHeaders---parserHeadersFromByteString :: Monad m => S.ByteString -> m (Either String (Status, [Header]))-parserHeadersFromByteString s = return $ parseOnly parseHeaders s+ getStatusLine = do+ status@(_, code, _) <- sinkLine >>= parseStatus+ if code == 100+ then newline ExpectedBlankAfter100Continue >> getStatusLine+ else return status + newline exc = do+ line <- sinkLine+ unless (S.null line) $ monadThrow exc -type Status = (S.ByteString, Int, S.ByteString)+ sinkLine = do+ bs <- fmap (killCR . S.concat) $ CB.takeWhile (/= charLF) =$ CL.consume+ CB.drop 1+ return bs+ charLF = 10+ charCR = 13+ charSpace = 32+ charColon = 58+ killCR bs+ | S.null bs = bs+ | S.last bs == charCR = S.init bs+ | otherwise = bs -parseStatus :: Parser Status-parseStatus = do- end <- atEnd- when end $ fail "EOF reached"- _ <- manyTill (take 1 >> return ()) (try $ string "HTTP/") <?> "HTTP/"- ver <- takeWhile1 $ not . isSpace- _ <- word8 32 -- space- statCode <- takeWhile1 isNumber- statCode' <-- case reads $ S8.unpack statCode of- [] -> fail $ "Invalid status code: " ++ S8.unpack statCode- (x, _):_ -> return x- statMsg <- try (word8 32 >> takeWhile notNewline) <|> return ""- newline- if (statCode == "100")- then newline >> parseStatus- else return (ver, statCode', statMsg)+ parseStatus :: MonadThrow m => S.ByteString -> m Status+ parseStatus bs = do+ let (ver, bs2) = S.breakByte charSpace bs+ (code, bs3) = S.breakByte charSpace $ S.dropWhile (== charSpace) bs2+ msg = S.dropWhile (== charSpace) bs3+ case (,) <$> parseVersion ver <*> parseCode code of+ Just (ver', code') -> return (ver', code', msg)+ _ -> monadThrow $ InvalidStatusLine bs -parseChunkHeader :: Parser Int-parseChunkHeader = do- len <- hexs- skipWhile isSpace- newline <|> attribs- return len+ stripPrefixBS x y+ | x `S.isPrefixOf` y = Just $ S.drop (S.length x) y+ | otherwise = Nothing+ parseVersion = stripPrefixBS "HTTP/"+ parseCode bs =+ case S8.readInt bs of+ Just (i, "") -> Just i+ _ -> Nothing -attribs :: Parser ()-attribs = do- _ <- word8 59 -- colon- skipWhile notNewline- newline+ parseHeaders front = do+ line <- sinkLine+ if S.null line+ then return $ front []+ else do+ header <- parseHeader line+ parseHeaders $ front . (header:) -hexs :: Parser Int-hexs = do- ws <- many1 hex- return $ foldl1 (\a b -> a * 16 + b) $ map fromIntegral ws+ parseHeader :: MonadThrow m => S.ByteString -> m Header+ parseHeader bs = do+ let (key, bs2) = S.breakByte charColon bs+ when (S.null bs2) $ monadThrow $ InvalidHeader bs+ return (strip key, strip $ S.drop 1 bs2) -hex :: Parser Word8-hex =- (digit <|> upper <|> lower) <?> "Hexadecimal digit"- where- digit = do- d <- satisfy $ \w -> (w >= 48 && w <= 57)- return $ d - 48- upper = do- d <- satisfy $ \w -> (w >= 65 && w <= 70)- return $ d - 55- lower = do- d <- satisfy $ \w -> (w >= 97 && w <= 102)- return $ d - 87+ strip = S.dropWhile (== charSpace) . fst . S.spanEnd (== charSpace)
Network/HTTP/Conduit/Request.hs view
@@ -175,10 +175,10 @@ , rawBody = False , decompress = browserDecompress , redirectCount = 10- , checkStatus = \s@(W.Status sci _) hs ->+ , checkStatus = \s@(W.Status sci _) hs cookie_jar -> if 200 <= sci && sci < 300 then Nothing- else Just $ toException $ StatusCodeException s hs+ else Just $ toException $ StatusCodeException s hs cookie_jar , responseTimeout = Just 5000000 , getConnectionWrapper = \mtimeout exc f -> case mtimeout of@@ -195,6 +195,7 @@ if remainingTime <= 0 then throwIO exc else return (Just remainingTime, res)+ , cookieJar = Just def } -- | Always decompress a compressed stream.
Network/HTTP/Conduit/Response.hs view
@@ -9,9 +9,8 @@ , lbsResponse ) where -import Control.Applicative ((<$>), (<*>)) import Control.Arrow (first)-import Control.Monad (liftM, unless, when)+import Control.Monad (liftM) import Control.Exception (throwIO) import Control.Monad.IO.Class (liftIO)@@ -22,6 +21,8 @@ import qualified Data.CaseInsensitive as CI +import Data.Default (def)+ import Data.Conduit hiding (Conduit) import Data.Conduit.Internal (ResumableSource (..), Pipe (..)) import qualified Data.Conduit.Zlib as CZ@@ -31,12 +32,13 @@ import qualified Network.HTTP.Types as W import Network.URI (parseURIReference) -import Network.HTTP.Conduit.Types (Response (..))+import Network.HTTP.Conduit.Types (Response (..), CookieJar) import Network.HTTP.Conduit.Manager import Network.HTTP.Conduit.Request import Network.HTTP.Conduit.Util import Network.HTTP.Conduit.Chunk+import Network.HTTP.Conduit.Parser (sinkHeaders) import Data.Void (Void, absurd) @@ -55,14 +57,21 @@ -- specific request, that user has to re-implement the redirect-following logic -- themselves. An example of that might look like this: ----- > myHttp req man = E.catch (runResourceT $ http req' man >> return [req'])--- > (\ (StatusCodeException status headers) -> do--- > l <- myHttp (fromJust $ nextRequest status headers) man--- > return $ req' : l)--- > where req' = req { redirectCount = 0 }--- > nextRequest status headers = getRedirectedRequest req' headers $ W.statusCode status-getRedirectedRequest :: Request m -> W.ResponseHeaders -> Int -> Maybe (Request m)-getRedirectedRequest req hs code+-- > myHttp req man = do+-- > (res, redirectRequests) <- (`runStateT` []) $+-- > 'httpRedirect'+-- > 9000+-- > (\req' -> do+-- > res <- http req'{redirectCount=0} man+-- > modify (\rqs -> req' : rqs)+-- > return (res, getRedirectedRequest req' (responseHeaders res) (responseCookieJar res) (W.statusCode (responseStatus res))+-- > )+-- > 'lift'+-- > req+-- > applyCheckStatus (checkStatus req) res+-- > return redirectRequests+getRedirectedRequest :: Request m -> W.ResponseHeaders -> CookieJar -> Int -> Maybe (Request m)+getRedirectedRequest req hs cookie_jar code | 300 <= code && code < 400 = do l' <- lookup "location" hs req' <- setUriRelative req =<< parseURIReference (S8.unpack l')@@ -74,9 +83,12 @@ then req' { method = "GET" , requestBody = RequestBodyBS ""+ , cookieJar = cookie_jar' }- else req'+ else req' {cookieJar = cookie_jar'} | otherwise = Nothing+ where+ cookie_jar' = fmap (const cookie_jar) $ cookieJar req -- | Convert a 'Response' that has a 'Source' body to one with a lazy -- 'L.ByteString' body.@@ -122,9 +134,9 @@ Just y -> return y (src2, ((vbs, sc, sm), hs)) <- timeout' $ src1 $$+ #if MIN_VERSION_conduit(1, 0, 0)- ConduitM (checkHeaderLength 4096 $ unConduitM sinkHeaders')+ ConduitM (checkHeaderLength 4096 $ unConduitM sinkHeaders) #else- (checkHeaderLength 4096 sinkHeaders')+ (checkHeaderLength 4096 sinkHeaders) #endif let version = if vbs == "1.1" then W.http11 else W.http10 let s = W.Status sc sm@@ -156,77 +168,7 @@ else src3 return $ addCleanup' cleanup src4 - return $ Response s version hs' body+ return $ Response s version hs' body def where fmapResume f (ResumableSource src m) = ResumableSource (f src) m addCleanup' f (ResumableSource src m) = ResumableSource (addCleanup f src) (m >> f False)---- | New version of @sinkHeaders@ that doesn't use attoparsec. Should create--- more meaningful exceptions.------ Since 1.8.7-sinkHeaders' :: (MonadThrow m, MonadResource m) => Sink S.ByteString m (Status, [Header])-sinkHeaders' = do- status <- getStatusLine- headers <- parseHeaders id- return (status, headers)- where- getStatusLine = do- status@(_, code, _) <- sinkLine >>= parseStatus- if code == 100- then newline ExpectedBlankAfter100Continue >> getStatusLine- else return status-- newline exc = do- line <- sinkLine- unless (S.null line) $ monadThrow exc-- sinkLine = do- bs <- fmap (killCR . S.concat) $ CB.takeWhile (/= charLF) =$ CL.consume- CB.drop 1- return bs- charLF = 10- charCR = 13- charSpace = 32- charColon = 58- killCR bs- | S.null bs = bs- | S.last bs == charCR = S.init bs- | otherwise = bs-- parseStatus :: MonadThrow m => S.ByteString -> m Status- parseStatus bs = do- let (ver, bs2) = S.breakByte charSpace bs- (code, bs3) = S.breakByte charSpace $ S.dropWhile (== charSpace) bs2- msg = S.dropWhile (== charSpace) bs3- case (,) <$> parseVersion ver <*> parseCode code of- Just (ver', code') -> return (ver', code', msg)- _ -> monadThrow $ InvalidStatusLine bs-- stripPrefixBS x y- | x `S.isPrefixOf` y = Just $ S.drop (S.length x) y- | otherwise = Nothing- parseVersion = stripPrefixBS "HTTP/"- parseCode bs =- case S8.readInt bs of- Just (i, "") -> Just i- _ -> Nothing-- parseHeaders front = do- line <- sinkLine- if S.null line- then return $ front []- else do- header <- parseHeader line- parseHeaders $ front . (header:)-- parseHeader :: MonadThrow m => S.ByteString -> m Header- parseHeader bs = do- let (key, bs2) = S.breakByte charColon bs- when (S.null bs2) $ monadThrow $ InvalidHeader bs- return (strip key, strip $ S.drop 1 bs2)-- strip = S.dropWhile (== charSpace) . fst . S.spanEnd (== charSpace)--type Header = (S.ByteString, S.ByteString)-type Status = (S.ByteString, Int, S.ByteString)
Network/HTTP/Conduit/Types.hs view
@@ -11,6 +11,8 @@ , ConnRelease , ConnReuse (..) , ManagedConn (..)+ , Cookie (..)+ , CookieJar (..) ) where import Data.Int (Int64)@@ -23,6 +25,10 @@ import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L +import Data.Time.Clock+import Data.Default+import qualified Data.List as DL+ import qualified Network.HTTP.Types as W import qualified Network.Socket as NS import Network.Socks5 (SocksConf)@@ -110,7 +116,7 @@ , redirectCount :: Int -- ^ How many redirects to follow when getting a resource. 0 means follow -- no redirects. Default value: 10.- , checkStatus :: W.Status -> W.ResponseHeaders -> Maybe SomeException+ , checkStatus :: W.Status -> W.ResponseHeaders -> CookieJar -> Maybe SomeException -- ^ Check the status code. Note that this will run after all redirects are -- performed. Default: return a @StatusCodeException@ on non-2XX responses. , responseTimeout :: Maybe Int@@ -129,7 +135,14 @@ -- Default: If @responseTimeout@ is @Nothing@, does nothing. Otherwise, -- institutes timeout, and returns remaining time for @responseTimeout@. --- -- Exported since 1.8.8+ -- Since 1.8.8+ , cookieJar :: Maybe CookieJar+ -- ^ A user-defined cookie jar.+ -- If 'Nothing', no cookie handling will take place, \"Cookie\" headers+ -- in 'requestHeaders' will be sent raw, and 'responseCookieJar' will be+ -- empty.+ --+ -- Since 1.9.0 } data ConnReuse = Reuse | DontReuse@@ -163,7 +176,7 @@ } deriving (Show, Read, Eq, Ord, Typeable) -data HttpException = StatusCodeException W.Status W.ResponseHeaders+data HttpException = StatusCodeException W.Status W.ResponseHeaders CookieJar | InvalidUrlException String String | TooManyRedirects [Response L.ByteString] -- ^ List of encountered responses containing redirects in reverse chronological order; including last redirect, which triggered the exception and was not followed. | UnparseableRedirect (Response L.ByteString) -- ^ Response containing unparseable redirect.@@ -177,21 +190,79 @@ | InvalidStatusLine S.ByteString | InvalidHeader S.ByteString | InternalIOException IOException+ | ProxyConnectException S.ByteString Int (Either S.ByteString HttpException) -- ^ host/port deriving (Show, Typeable) instance Exception HttpException -- | A simple representation of the HTTP response created by 'lbsConsumer'. data Response body = Response { responseStatus :: W.Status+ -- ^ Status code of the response. , responseVersion :: W.HttpVersion+ -- ^ HTTP version used by the server. , responseHeaders :: W.ResponseHeaders+ -- ^ Response headers sent by the server. , responseBody :: body+ -- ^ Response body sent by the server.+ , responseCookieJar :: CookieJar+ -- ^ Cookies set on the client after interacting with the server. If+ -- cookies have been disabled by setting 'cookieJar' to @Nothing@, then+ -- this will always be empty. } deriving (Show, Eq, Typeable) +-- This corresponds to the description of a cookie detailed in Section 5.3 \"Storage Model\"+data Cookie = Cookie+ { cookie_name :: S.ByteString+ , cookie_value :: S.ByteString+ , cookie_expiry_time :: UTCTime+ , cookie_domain :: S.ByteString+ , cookie_path :: S.ByteString+ , cookie_creation_time :: UTCTime+ , cookie_last_access_time :: UTCTime+ , cookie_persistent :: Bool+ , cookie_host_only :: Bool+ , cookie_secure_only :: Bool+ , cookie_http_only :: Bool+ }+ deriving (Show)++newtype CookieJar = CJ { expose :: [Cookie] }+ deriving (Show)++-- This corresponds to step 11 of the algorithm described in Section 5.3 \"Storage Model\"+instance Eq Cookie where+ (==) a b = name_matches && domain_matches && path_matches+ where name_matches = cookie_name a == cookie_name b+ domain_matches = cookie_domain a == cookie_domain b+ path_matches = cookie_path a == cookie_path b++instance Ord Cookie where+ compare c1 c2+ | S.length (cookie_path c1) > S.length (cookie_path c2) = LT+ | S.length (cookie_path c1) < S.length (cookie_path c2) = GT+ | cookie_creation_time c1 > cookie_creation_time c2 = GT+ | otherwise = LT++instance Default CookieJar where+ def = CJ []++instance Eq CookieJar where+ (==) cj1 cj2 = (DL.sort $ expose cj1) == (DL.sort $ expose cj2)++-- | Since 1.9+instance Monoid CookieJar where+ mempty = def+ (CJ a) `mappend` (CJ b) = CJ (DL.nub $ DL.sortBy compare' $ a `mappend` b)+ where compare' c1 c2 =+ -- inverse so that recent cookies are kept by nub over older+ if cookie_creation_time c1 > cookie_creation_time c2+ then LT+ else GT+ -- | Since 1.1.2. instance Functor Response where- fmap f (Response status v headers body) = Response status v headers (f body)+ fmap f response = response {responseBody = f (responseBody response)} -- | Since 1.8.7 instance Show (RequestBody m) where
http-conduit.cabal view
@@ -1,14 +1,14 @@ name: http-conduit-version: 1.8.9+version: 1.9.0 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com> maintainer: Michael Snoyman <michael@snoyman.com> synopsis: HTTP client package with conduit interface and HTTPS support. description:- This package uses attoparsec for parsing the actual contents of the HTTP connection. It also provides higher-level functions which allow you to avoid direct usage of conduits. See <http://www.yesodweb.com/book/http-conduit> for more information.+ This package uses conduit for parsing the actual contents of the HTTP connection. It also provides higher-level functions which allow you to avoid directly dealing with streaming data. See <http://www.yesodweb.com/book/http-conduit> for more information. .- "Network.HTTP.Conduit.Browser" module has been moved to <http://hackage.haskell.org/package/http-conduit-browser/>+ The @Network.HTTP.Conduit.Browser@ module has been moved to <http://hackage.haskell.org/package/http-conduit-browser/> category: Web, Conduit stability: Stable cabal-version: >= 1.8@@ -31,8 +31,6 @@ , conduit >= 0.5.5 && < 1.1 , zlib-conduit >= 0.5 && < 1.1 , blaze-builder-conduit >= 0.5- , attoparsec-conduit >= 0.5- , attoparsec >= 0.8.0.2 , utf8-string >= 0.3.4 , blaze-builder >= 0.2.1 , http-types >= 0.7@@ -57,6 +55,7 @@ , regex-compat , mtl , deepseq+ , publicsuffixlist >= 0.0.3 && < 1.0 , array >= 0.3 , random , filepath@@ -95,8 +94,6 @@ , conduit , zlib-conduit , blaze-builder-conduit- , attoparsec-conduit- , attoparsec , utf8-string , blaze-builder , http-types@@ -126,6 +123,7 @@ , void , deepseq , mtl+ , publicsuffixlist , array , random , filepath
test/CookieTest.hs view
@@ -5,8 +5,10 @@ import qualified Data.ByteString as BS import Test.HUnit hiding (path) import Network.HTTP.Conduit.Cookies+import Network.HTTP.Conduit.Types import qualified Network.HTTP.Conduit as HC import Data.ByteString.UTF8+import Data.Monoid import Data.Maybe import Data.Time.Clock import Data.Time.Calendar@@ -106,8 +108,8 @@ testSamePathsMatch :: Test testSamePathsMatch = TestCase $ assertBool "The same path should match" $- pathMatches path path- where path = fromString "/a/path"+ pathMatches path' path'+ where path' = fromString "/a/path" testPathSlashAtEnd :: Test testPathSlashAtEnd = TestCase $ assertBool "Putting the slash at the end should still match paths" $@@ -441,6 +443,13 @@ default_time (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie default_set_cookie default_request default_time False $ createCookieJar [existing_cookie]) where existing_cookie = default_cookie {cookie_http_only = True} +testMonoidPreferRecent :: Test+testMonoidPreferRecent = TestCase $ assertEqual "Monoid prefers more recent cookies"+ (cct $ createCookieJar [c2]) (cct $ createCookieJar [c1] `mappend` createCookieJar [c2])+ where c1 = default_cookie {cookie_creation_time = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 1)}+ c2 = default_cookie {cookie_creation_time = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 2)}+ cct cj = cookie_creation_time $ head $ destroyCookieJar cj+ ipParseTests :: Spec ipParseTests = do it "Valid IP" testValidIp@@ -533,6 +542,10 @@ it "Max-Age flag gets set correctly" testReceiveSetCookieMaxAge it "Max-Age is preferred over Expires" testReceiveSetCookiePreferMaxAge +monoidTests :: Spec+monoidTests = do+ it "Monoid prefers more recent cookies" testMonoidPreferRecent+ cookieTest :: Spec cookieTest = do describe "ipParseTests" ipParseTests@@ -544,3 +557,4 @@ describe "evictionTests" evictionTests describe "sendingTests" sendingTests describe "receivingTests" receivingTests+ describe "monoidTest" monoidTests
test/main.hs view
@@ -9,6 +9,7 @@ import qualified Network.Wai as Wai import Network.Wai.Handler.Warp (runSettings, defaultSettings, settingsPort, settingsBeforeMainLoop) import Network.HTTP.Conduit hiding (port)+import qualified Network.HTTP.Conduit as NHC import Network.HTTP.Conduit.MultipartFormData import Control.Concurrent (forkIO, killThread, putMVar, takeMVar, newEmptyMVar) import Network.HTTP.Types@@ -37,7 +38,32 @@ import Blaze.ByteString.Builder (fromByteString, toByteString) import System.IO import Data.Monoid (mconcat)+import Data.Time.Clock+import Data.Time.Calendar +past :: UTCTime+past = UTCTime (ModifiedJulianDay 56200) (secondsToDiffTime 0)++future :: UTCTime+future = UTCTime (ModifiedJulianDay 562000) (secondsToDiffTime 0)++cookie :: Cookie+cookie = Cookie { cookie_name = "key"+ , cookie_value = "value"+ , cookie_expiry_time = future+ , cookie_domain = "127.0.0.1"+ , cookie_path = "/dump_cookies"+ , cookie_creation_time = past+ , cookie_last_access_time = past+ , cookie_persistent = False+ , cookie_host_only = False+ , cookie_secure_only = False+ , cookie_http_only = False+ }++cookie_jar :: CookieJar+cookie_jar = createCookieJar [cookie]+ app :: Application app req = case pathInfo req of@@ -55,6 +81,7 @@ in return $ responseLBS status303 [(hLocation, S.append "/infredir/" $ S8.pack $ show $ i+1)] (L8.pack $ show i)+ ["dump_cookies"] -> return $ responseLBS status200 [] $ L.fromChunks $ return $ maybe "" id $ lookup hCookie $ Wai.requestHeaders req _ -> return $ responseLBS status404 [] "not found" where tastyCookie = (mk (fromString "Set-Cookie"), fromString "flavor=chocolate-chip;")@@ -105,15 +132,41 @@ it "preserves 'set-cookie' headers" $ withApp app $ \port -> do request <- parseUrl $ concat ["http://127.0.0.1:", show port, "/cookies"] withManager $ \manager -> do- Response _ _ headers _ <- httpLbs request manager+ response <- httpLbs request manager let setCookie = mk (fromString "Set-Cookie")- (setCookieHeaders, _) = partition ((== setCookie) . fst) headers+ (setCookieHeaders, _) = partition ((== setCookie) . fst) (responseHeaders response) liftIO $ assertBool "response contains a 'set-cookie' header" $ length setCookieHeaders > 0 it "redirects set cookies" $ withApp app $ \port -> do request <- parseUrl $ concat ["http://127.0.0.1:", show port, "/cookie_redir1"] withManager $ \manager -> do- Response _ _ _ body <- httpLbs request manager- liftIO $ body @?= "nom-nom-nom"+ response <- httpLbs request manager+ liftIO $ (responseBody response) @?= "nom-nom-nom"+ it "user-defined cookie jar works" $ withApp app $ \port -> do+ request <- parseUrl $ concat ["http://127.0.0.1:", show port, "/dump_cookies"]+ withManager $ \manager -> do+ response <- httpLbs (request {redirectCount = 1, cookieJar = Just cookie_jar}) manager+ liftIO $ (responseBody response) @?= "key=value"+ it "user-defined cookie jar is not ignored when redirection is disabled" $ withApp app $ \port -> do+ request <- parseUrl $ concat ["http://127.0.0.1:", show port, "/dump_cookies"]+ withManager $ \manager -> do+ response <- httpLbs (request {redirectCount = 0, cookieJar = Just cookie_jar}) manager+ liftIO $ (responseBody response) @?= "key=value"+ it "cookie jar is available in response" $ withApp app $ \port -> do+ request <- parseUrl $ concat ["http://127.0.0.1:", show port, "/cookies"]+ withManager $ \manager -> do+ response <- httpLbs (request {cookieJar = Just def}) manager+ liftIO $ (length $ destroyCookieJar $ responseCookieJar response) @?= 1+ it "Cookie header isn't touched when no cookie jar supplied" $ withApp app $ \port -> do+ request <- parseUrl $ concat ["http://127.0.0.1:", show port, "/dump_cookies"]+ withManager $ \manager -> do+ let request_headers = (mk "Cookie", "key2=value2") : filter ((/= mk "Cookie") . fst) (NHC.requestHeaders request)+ response <- httpLbs (request {NHC.requestHeaders = request_headers, cookieJar = Nothing}) manager+ liftIO $ (responseBody response) @?= "key2=value2"+ it "Response cookie jar is nothing when request cookie jar is nothing" $ withApp app $ \port -> do+ request <- parseUrl $ concat ["http://127.0.0.1:", show port, "/cookies"]+ withManager $ \manager -> do+ response <- httpLbs (request {cookieJar = Nothing}) manager+ liftIO $ (responseCookieJar response) @?= def describe "manager" $ do it "closes all connections" $ withApp app $ \port1 -> withApp app $ \port2 -> do clearSocketsList@@ -216,7 +269,7 @@ describe "HTTP/1.0" $ do it "BaseHTTP" $ do let baseHTTP app' = do- appSource app' $$ await+ _ <- appSource app' $$ await yield "HTTP/1.0 200 OK\r\n\r\nThis is it!" $$ appSink app' withCApp baseHTTP $ \port -> withManager $ \manager -> do req <- parseUrl $ "http://127.0.0.1:" ++ show port