diff --git a/Network/HTTP/Client.hs b/Network/HTTP/Client.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Client.hs @@ -0,0 +1,118 @@ +-- | This is the main entry point for using http-client. Used by itself, this +-- module provides low-level access for streaming request and response bodies, +-- and only non-secure HTTP connections. Helper packages such as http-conduit +-- provided higher level streaming approaches, while other helper packages like +-- http-client-tls provide secure connections. +-- +-- There are three core components to be understood here: requests, responses, +-- and managers. A @Manager@ keeps track of open connections to various hosts, +-- and when requested, will provide either an existing open connection or +-- create a new connection on demand. A @Manager@ also automatically reaps +-- connections which have been unused for a certain period of time. A @Manager@ +-- allows for more efficient HTTP usage by allowing for keep-alive connections. +-- Secure HTTP connections can be allowed by modifying the settings used for +-- creating a manager. The simplest way to create a @Manager@ is with: +-- +-- > 'newManager' 'defaultManagerSettings' +-- +-- The next core component is a @Request@, which represents a single HTTP +-- request to be sent to a specific server. @Request@s allow for many settings +-- to control exact how they function, but usually the simplest approach for +-- creating a @Request@ is to use 'parseUrl'. +-- +-- Finally, a @Response@ is the result of sending a single @Request@ to a +-- server, over a connection which was acquired from a @Manager@. Note that you +-- must close the response when you're done with it to ensure that the +-- connection is recycled to the @Manager@ to either be used by another +-- request, or to be reaped. Usage of @withResponse@ will ensure that this +-- happens automatically. +-- +-- Helper packages may provide replacements for various recommendations listed +-- above. For example, if using http-client-tls, instead of using +-- 'defaultManagerSettings', you would want to use @tlsManagerSettings@. Be +-- sure to read the relevant helper library documentation for more information. +-- +-- A note on exceptions: for the most part, all actions that perform I/O should +-- be assumed to throw an @HttpException@ in the event of some problem, and all +-- pure functions will be total. For example, @withResponse@, @httpLbs@, and +-- @brRead@ can all throw exceptions. Functions like @responseStatus@ and +-- @applyBasicAuth@ are guaranteed to be total (or there\'s a bug in the +-- library). +-- +-- One thing to be cautioned about: the type of @parseUrl@ allows it to work in +-- different monads. If used in the @IO@ monad, it will throw an exception in +-- the case of an invalid URI. In addition, if you leverage the @IsString@ +-- instance of the @Request@ value via @OverloadedStrings@, an invalid URI will +-- result in a partial value. Caveat emptor! +module Network.HTTP.Client + ( -- * Performing requests + withResponse + , httpLbs + , responseOpen + , responseClose + -- * Connection manager + , Manager + , newManager + , closeManager + -- ** Connection manager settings + , ManagerSettings + , defaultManagerSettings + , managerConnCount + , managerRawConnection + , managerTlsConnection + , managerResponseTimeout + , managerRetryableException + , managerWrapIOException + -- * Request + , parseUrl + , applyBasicAuth + , urlEncodedBody + , getUri + -- ** Request type and fields + , Request + , method + , secure + , host + , port + , path + , queryString + , requestHeaders + , requestBody + , proxy + , decompress + , redirectCount + , checkStatus + , responseTimeout + , cookieJar + -- ** Request body + , RequestBody (..) + , Popper + , NeedsPopper + , GivesPopper + -- * Response + , Response + , responseStatus + , responseVersion + , responseHeaders + , responseBody + , responseCookieJar + -- ** Response body + , BodyReader + , brRead + , brConsume + -- * Misc + , HttpException (..) + , Cookie (..) + , CookieJar + , Proxy (..) + -- * Cookies + , module Network.HTTP.Client.Cookies + ) where + +import Network.HTTP.Client.Body +import Network.HTTP.Client.Cookies +import Network.HTTP.Client.Core +import Network.HTTP.Client.Manager +import Network.HTTP.Client.Request +import Network.HTTP.Client.Response +import Network.HTTP.Client.Types diff --git a/Network/HTTP/Client/Body.hs b/Network/HTTP/Client/Body.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Client/Body.hs @@ -0,0 +1,201 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +module Network.HTTP.Client.Body + ( makeChunkedReader + , makeLengthReader + , makeGzipReader + , makeUnlimitedReader + , brConsume + , brEmpty + , brAddCleanup + , brReadSome + ) where + +import Network.HTTP.Client.Connection +import Network.HTTP.Client.Types +import Control.Exception (throwIO, assert) +import Data.ByteString (ByteString, empty, uncons) +import Data.IORef +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import Control.Monad (unless, when) +import qualified Codec.Zlib as Z + +brReadSome :: BodyReader -> Int -> IO L.ByteString +brReadSome BodyReader {..} = + loop id + where + loop front rem + | rem <= 0 = return $ L.fromChunks $ front [] + | otherwise = do + bs <- brRead + if S.null bs + then return $ L.fromChunks $ front [] + else loop (front . (bs:)) (rem - S.length bs) + +brEmpty :: BodyReader +brEmpty = BodyReader + { brRead = return S.empty + , brComplete = return True + } + +brAddCleanup :: IO () -> BodyReader -> BodyReader +brAddCleanup cleanup br = BodyReader + { brRead = do + bs <- brRead br + when (S.null bs) cleanup + return bs + , brComplete = brComplete br + } + +-- | Strictly consume all remaining chunks of data from the stream. +-- +-- Since 0.1.0 +brConsume :: BodyReader -> IO [S.ByteString] +brConsume f = + go id + where + go front = do + x <- brRead f + if S.null x + then return $ front [] + else go (front . (x:)) + +makeGzipReader :: BodyReader -> IO BodyReader +makeGzipReader br = do + inf <- Z.initInflate $ Z.WindowBits 31 + istate <- newIORef Nothing + let goPopper popper = do + mbs <- popper + case mbs of + Just bs -> do + writeIORef istate $ Just popper + return bs + Nothing -> do + bs <- Z.flushInflate inf + if S.null bs + then start + else do + writeIORef istate Nothing + return bs + start = do + bs <- brRead br + if S.null bs + then return S.empty + else do + popper <- Z.feedInflate inf bs + goPopper popper + return BodyReader + { brRead = do + state <- readIORef istate + case state of + Nothing -> start + Just popper -> goPopper popper + , brComplete = brComplete br + } + +makeUnlimitedReader :: Connection -> IO BodyReader +makeUnlimitedReader Connection {..} = do + icomplete <- newIORef False + return $! BodyReader + { brRead = do + bs <- connectionRead + when (S.null bs) $ writeIORef icomplete True + return bs + , brComplete = readIORef icomplete + } + +makeLengthReader :: Int -> Connection -> IO BodyReader +makeLengthReader count0 Connection {..} = do + icount <- newIORef count0 + return $! BodyReader + { brRead = do + count <- readIORef icount + if count <= 0 + then return empty + else do + bs <- connectionRead + when (S.null bs) $ throwIO $ ResponseBodyTooShort (fromIntegral count0) (fromIntegral $ count0 - count) + case compare count $ S.length bs of + LT -> do + let (x, y) = S.splitAt count bs + connectionUnread y + writeIORef icount (-1) + return x + EQ -> do + writeIORef icount (-1) + return bs + GT -> do + writeIORef icount (count - S.length bs) + return bs + , brComplete = fmap (== -1) $ readIORef icount + } + +makeChunkedReader :: Bool -- ^ send headers + -> Connection + -> IO BodyReader +makeChunkedReader sendHeaders conn@Connection {..} = do + icount <- newIORef 0 + return $! BodyReader + { brRead = go icount + , brComplete = do + count <- readIORef icount + return $! count == -1 + } + where + go icount = do + count0 <- readIORef icount + count <- + if count0 == 0 + then readHeader + else return count0 + if count <= 0 + then do + writeIORef icount (-1) + return empty + else do + (bs, count') <- sendChunk count + writeIORef icount count' + return bs + + sendChunk 0 = return (empty, 0) + sendChunk remainder = do + bs <- connectionRead + when (S.null bs) $ throwIO InvalidChunkHeaders + case compare remainder $ S.length bs of + LT -> do + let (x, y) = S.splitAt remainder bs + assert (not $ S.null y) $ connectionUnread y + requireNewline + return (x, 0) + EQ -> do + requireNewline + return (bs, 0) + GT -> return (bs, remainder - S.length bs) + + requireNewline = do + bs <- connectionReadLine conn + unless (S.null bs) $ throwIO InvalidChunkHeaders + + readHeader = do + bs <- connectionReadLine conn + case parseHex bs of + Nothing -> throwIO InvalidChunkHeaders + Just hex -> return hex + + parseHex bs0 = + case uncons bs0 of + Just (w0, bs') + | Just i0 <- toI w0 -> Just $ parseHex' i0 bs' + _ -> Nothing + parseHex' i bs = + case uncons bs of + Just (w, bs) + | Just i' <- toI w -> parseHex' (i * 16 + i') bs + _ -> i + + toI w + | 48 <= w && w <= 57 = Just $ fromIntegral w - 48 + | 65 <= w && w <= 70 = Just $ fromIntegral w - 55 + | 97 <= w && w <= 102 = Just $ fromIntegral w - 87 + | otherwise = Nothing diff --git a/Network/HTTP/Client/Connection.hs b/Network/HTTP/Client/Connection.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Client/Connection.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} +module Network.HTTP.Client.Connection + ( connectionReadLine + , connectionReadLineWith + , dummyConnection + , openSocketConnection + , makeConnection + ) where + +import Data.ByteString (ByteString, empty) +import Data.IORef +import Control.Monad +import Control.Exception (throwIO) +import Network.HTTP.Client.Types +import Network.Socket (Socket, sClose, HostAddress) +import qualified Network.Socket as NS +import Network.Socket.ByteString (sendAll, recv) +import qualified Control.Exception as E +import qualified Data.ByteString as S +import Data.Word (Word8) + +connectionReadLine :: Connection -> IO ByteString +connectionReadLine conn = do + bs <- connectionRead conn + when (S.null bs) $ throwIO IncompleteHeaders + connectionReadLineWith conn bs + +connectionReadLineWith :: Connection -> ByteString -> IO ByteString +connectionReadLineWith conn bs0 = + go bs0 id 0 + where + go bs front total = + case S.breakByte charLF bs of + (_, "") -> do + let total' = total + S.length bs + when (total' > 1024) $ throwIO OverlongHeaders + bs' <- connectionRead conn + when (S.null bs') $ throwIO IncompleteHeaders + go bs' (front . (bs:)) total' + (x, S.drop 1 -> y) -> do + unless (S.null y) $! connectionUnread conn y + return $! killCR $! S.concat $! front [x] + +charLF, charCR :: Word8 +charLF = 10 +charCR = 13 + +killCR :: ByteString -> ByteString +killCR bs + | S.null bs = bs + | S.last bs == charCR = S.init bs + | otherwise = bs + + +-- | For testing +dummyConnection :: [ByteString] -- ^ input + -> IO (Connection, IO [ByteString], IO [ByteString]) -- ^ conn, output, input +dummyConnection input0 = do + iinput <- newIORef input0 + ioutput <- newIORef [] + return (Connection + { connectionRead = atomicModifyIORef iinput $ \input -> + case input of + [] -> ([], empty) + x:xs -> (xs, x) + , connectionUnread = \x -> atomicModifyIORef iinput $ \input -> (x:input, ()) + , connectionWrite = \x -> atomicModifyIORef ioutput $ \output -> (output ++ [x], ()) + , connectionClose = return () + }, atomicModifyIORef ioutput $ \output -> ([], output), readIORef iinput) + +makeConnection :: IO ByteString -- ^ read + -> (ByteString -> IO ()) -- ^ write + -> IO () -- ^ close + -> IO Connection +makeConnection r w c = do + istack <- newIORef [] + _ <- mkWeakIORef istack c + return $! Connection + { connectionRead = join $ atomicModifyIORef istack $ \stack -> + case stack of + x:xs -> (xs, return x) + [] -> ([], r) + , connectionUnread = \x -> atomicModifyIORef istack $ \stack -> (x:stack, ()) + , connectionWrite = w + , connectionClose = c + } + +socketConnection :: Socket -> IO Connection +socketConnection socket = makeConnection + (recv socket 4096) + (sendAll socket) + (sClose socket) + +openSocketConnection :: Maybe HostAddress + -> String -- ^ host + -> Int -- ^ port + -> IO Connection +openSocketConnection hostAddress host port = do + let hints = NS.defaultHints { + NS.addrFlags = [NS.AI_ADDRCONFIG] + , NS.addrSocketType = NS.Stream + } + addrs <- case hostAddress of + Nothing -> + NS.getAddrInfo (Just hints) (Just host) (Just $ show port) + Just ha -> + return + [NS.AddrInfo + { NS.addrFlags = [] + , NS.addrFamily = NS.AF_INET + , NS.addrSocketType = NS.Stream + , NS.addrProtocol = 6 -- tcp + , NS.addrAddress = NS.SockAddrInet (toEnum port) ha + , NS.addrCanonName = Nothing + }] + + firstSuccessful addrs $ \addr -> + E.bracketOnError + (NS.socket (NS.addrFamily addr) (NS.addrSocketType addr) + (NS.addrProtocol addr)) + (NS.sClose) + (\sock -> do + NS.setSocketOption sock NS.NoDelay 1 + NS.connect sock (NS.addrAddress addr) + socketConnection sock) + +firstSuccessful :: [NS.AddrInfo] -> (NS.AddrInfo -> IO a) -> IO a +firstSuccessful [] _ = error "getAddrInfo returned empty list" +firstSuccessful (a:as) cb = + cb a `E.catch` \(e :: E.IOException) -> + case as of + [] -> E.throwIO e + _ -> firstSuccessful as cb diff --git a/Network/HTTP/Client/Cookies.hs b/Network/HTTP/Client/Cookies.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Client/Cookies.hs @@ -0,0 +1,250 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | This module implements the algorithms described in RFC 6265 for the Network.HTTP.Conduit library. +module Network.HTTP.Client.Cookies + ( updateCookieJar + , receiveSetCookie + , generateCookie + , insertCheckedCookie + , insertCookiesIntoRequest + , computeCookieString + , evictExpiredCookies + , createCookieJar + , destroyCookieJar + , pathMatches + , removeExistingCookieFromCookieJar + , domainMatches + , isIpAddress + , defaultPath + ) where + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as S8 +import Data.Maybe +import qualified Data.List as L +import Data.Time.Clock +import Data.Time.Calendar +import Web.Cookie +import qualified Data.CaseInsensitive as CI +import Blaze.ByteString.Builder +import qualified Network.PublicSuffixList.Lookup as PSL +import Data.Text.Encoding (decodeUtf8With) +import Data.Text.Encoding.Error (lenientDecode) + +import qualified Network.HTTP.Client.Request as Req +import qualified Network.HTTP.Client.Response as Res +import Network.HTTP.Client.Types as Req + +slash :: Integral a => a +slash = 47 -- '/' + +isIpAddress :: BS.ByteString -> Bool +isIpAddress = + go 4 + where + go 0 bs = BS.null bs + go rest bs = + case S8.readInt x of + Just (i, x') | BS.null x' && i >= 0 && i < 256 -> go (rest - 1) y + _ -> False + where + (x, y') = BS.breakByte 46 bs -- period + y = BS.drop 1 y' + +-- | This corresponds to the subcomponent algorithm entitled \"Domain Matching\" detailed +-- in section 5.1.3 +domainMatches :: BS.ByteString -> BS.ByteString -> Bool +domainMatches string domainString + | string == domainString = True + | BS.length string < BS.length domainString + 1 = False + | domainString `BS.isSuffixOf` string && BS.singleton (BS.last difference) == "." && not (isIpAddress string) = True + | otherwise = False + where difference = BS.take (BS.length string - BS.length domainString) string + +-- | This corresponds to the subcomponent algorithm entitled \"Paths\" detailed +-- in section 5.1.4 +defaultPath :: Req.Request -> BS.ByteString +defaultPath req + | BS.null uri_path = "/" + | BS.singleton (BS.head uri_path) /= "/" = "/" + | BS.count slash uri_path <= 1 = "/" + | otherwise = BS.reverse $ BS.tail $ BS.dropWhile (/= slash) $ BS.reverse uri_path + where uri_path = Req.path req + +-- | This corresponds to the subcomponent algorithm entitled \"Path-Match\" detailed +-- 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) == "/" = True + | cookiePath `BS.isPrefixOf` path' && BS.singleton (BS.head remainder) == "/" = True + | otherwise = False + where remainder = BS.drop (BS.length cookiePath) requestPath + path' = case S8.uncons requestPath of + Just ('/', _) -> requestPath + _ -> '/' `S8.cons` requestPath + +createCookieJar :: [Cookie] -> CookieJar +createCookieJar = CJ + +destroyCookieJar :: CookieJar -> [Cookie] +destroyCookieJar = expose + +insertIntoCookieJar :: Cookie -> CookieJar -> CookieJar +insertIntoCookieJar cookie cookie_jar' = CJ $ cookie : cookie_jar + where cookie_jar = expose cookie_jar' + +removeExistingCookieFromCookieJar :: Cookie -> CookieJar -> (Maybe Cookie, CookieJar) +removeExistingCookieFromCookieJar cookie cookie_jar' = (mc, CJ lc) + where (mc, lc) = removeExistingCookieFromCookieJarHelper cookie (expose cookie_jar') + removeExistingCookieFromCookieJarHelper _ [] = (Nothing, []) + removeExistingCookieFromCookieJarHelper c (c' : cs) + | c == c' = (Just c', cs) + | otherwise = (cookie', c' : cookie_jar'') + where (cookie', cookie_jar'') = removeExistingCookieFromCookieJarHelper c cs + +-- | Are we configured to reject cookies for domains such as \"com\"? +rejectPublicSuffixes :: Bool +rejectPublicSuffixes = True + +isPublicSuffix :: BS.ByteString -> Bool +isPublicSuffix = PSL.isSuffix . decodeUtf8With lenientDecode + +-- | This corresponds to the eviction algorithm described in Section 5.3 \"Storage Model\" +evictExpiredCookies :: CookieJar -- ^ Input cookie jar + -> UTCTime -- ^ Value that should be used as \"now\" + -> CookieJar -- ^ Filtered cookie jar +evictExpiredCookies cookie_jar' now = CJ $ filter (\ cookie -> cookie_expiry_time cookie >= now) $ expose cookie_jar' + +-- | This applies the 'computeCookieString' to a given Request +insertCookiesIntoRequest :: Req.Request -- ^ The request to insert into + -> CookieJar -- ^ Current cookie jar + -> UTCTime -- ^ Value that should be used as \"now\" + -> (Req.Request, CookieJar) -- ^ (Ouptut request, Updated cookie jar (last-access-time is updated)) +insertCookiesIntoRequest request cookie_jar now + | BS.null cookie_string = (request, cookie_jar') + | otherwise = (request {Req.requestHeaders = cookie_header : purgedHeaders}, cookie_jar') + where purgedHeaders = L.deleteBy (\ (a, _) (b, _) -> a == b) (CI.mk $ "Cookie", BS.empty) $ Req.requestHeaders request + (cookie_string, cookie_jar') = computeCookieString request cookie_jar now True + cookie_header = (CI.mk $ "Cookie", cookie_string) + +-- | This corresponds to the algorithm described in Section 5.4 \"The Cookie Header\" +computeCookieString :: Req.Request -- ^ Input request + -> CookieJar -- ^ Current cookie jar + -> UTCTime -- ^ Value that should be used as \"now\" + -> Bool -- ^ Whether or not this request is coming from an \"http\" source (not javascript or anything like that) + -> (BS.ByteString, CookieJar) -- ^ (Contents of a \"Cookie\" header, Updated cookie jar (last-access-time is updated)) +computeCookieString request cookie_jar now is_http_api = (output_line, cookie_jar') + where matching_cookie cookie = condition1 && condition2 && condition3 && condition4 + where condition1 + | cookie_host_only cookie = Req.host request == cookie_domain cookie + | otherwise = domainMatches (Req.host request) (cookie_domain cookie) + condition2 = pathMatches (Req.path request) (cookie_path cookie) + condition3 + | not (cookie_secure_only cookie) = True + | otherwise = Req.secure request + condition4 + | not (cookie_http_only cookie) = True + | otherwise = is_http_api + matching_cookies = filter matching_cookie $ expose cookie_jar + output_cookies = map (\ c -> (cookie_name c, cookie_value c)) $ L.sort matching_cookies + output_line = toByteString $ renderCookies $ output_cookies + folding_function cookie_jar'' cookie = case removeExistingCookieFromCookieJar cookie cookie_jar'' of + (Just c, cookie_jar''') -> insertIntoCookieJar (c {cookie_last_access_time = now}) cookie_jar''' + (Nothing, cookie_jar''') -> cookie_jar''' + cookie_jar' = foldl folding_function cookie_jar matching_cookies + +-- | This applies 'receiveSetCookie' to a given Response +updateCookieJar :: Response a -- ^ Response received from server + -> Request -- ^ Request which generated the response + -> UTCTime -- ^ Value that should be used as \"now\" + -> CookieJar -- ^ Current cookie jar + -> (CookieJar, Response a) -- ^ (Updated cookie jar with cookies from the Response, The response stripped of any \"Set-Cookie\" header) +updateCookieJar response request now cookie_jar = (cookie_jar', response { responseHeaders = other_headers }) + where (set_cookie_headers, other_headers) = L.partition ((== (CI.mk $ "Set-Cookie")) . fst) $ responseHeaders response + set_cookie_data = map snd set_cookie_headers + set_cookies = map parseSetCookie set_cookie_data + cookie_jar' = foldl (\ cj sc -> receiveSetCookie sc request now True cj) cookie_jar set_cookies + +-- | This corresponds to the algorithm described in Section 5.3 \"Storage Model\" +-- This function consists of calling 'generateCookie' followed by 'insertCheckedCookie'. +-- Use this function if you plan to do both in a row. +-- 'generateCookie' and 'insertCheckedCookie' are only provided for more fine-grained control. +receiveSetCookie :: SetCookie -- ^ The 'SetCookie' the cookie jar is receiving + -> Req.Request -- ^ The request that originated the response that yielded the 'SetCookie' + -> UTCTime -- ^ Value that should be used as \"now\" + -> Bool -- ^ Whether or not this request is coming from an \"http\" source (not javascript or anything like that) + -> CookieJar -- ^ Input cookie jar to modify + -> CookieJar -- ^ Updated cookie jar +receiveSetCookie set_cookie request now is_http_api cookie_jar = case (do + cookie <- generateCookie set_cookie request now is_http_api + return $ insertCheckedCookie cookie cookie_jar is_http_api) of + Just cj -> cj + Nothing -> cookie_jar + +-- | Insert a cookie created by generateCookie into the cookie jar (or not if it shouldn't be allowed in) +insertCheckedCookie :: Cookie -- ^ The 'SetCookie' the cookie jar is receiving + -> CookieJar -- ^ Input cookie jar to modify + -> Bool -- ^ Whether or not this request is coming from an \"http\" source (not javascript or anything like that) + -> CookieJar -- ^ Updated (or not) cookie jar +insertCheckedCookie c cookie_jar is_http_api = case (do + (cookie_jar', cookie') <- existanceTest c cookie_jar + return $ insertIntoCookieJar cookie' cookie_jar') of + Just cj -> cj + Nothing -> cookie_jar + where existanceTest cookie cookie_jar' = existanceTestHelper cookie $ removeExistingCookieFromCookieJar cookie cookie_jar' + existanceTestHelper new_cookie (Just old_cookie, cookie_jar') + | not is_http_api && cookie_http_only old_cookie = Nothing + | otherwise = return (cookie_jar', new_cookie {cookie_creation_time = cookie_creation_time old_cookie}) + existanceTestHelper new_cookie (Nothing, cookie_jar') = return (cookie_jar', new_cookie) + +-- | Turn a SetCookie into a Cookie, if it is valid +generateCookie :: SetCookie -- ^ The 'SetCookie' we are encountering + -> Req.Request -- ^ The request that originated the response that yielded the 'SetCookie' + -> UTCTime -- ^ Value that should be used as \"now\" + -> Bool -- ^ Whether or not this request is coming from an \"http\" source (not javascript or anything like that) + -> Maybe Cookie -- ^ The optional output cookie +generateCookie set_cookie request now is_http_api = do + domain_sanitized <- sanitizeDomain $ step4 (setCookieDomain set_cookie) + domain_intermediate <- step5 domain_sanitized + (domain_final, host_only') <- step6 domain_intermediate + http_only' <- step10 + return $ Cookie { cookie_name = setCookieName set_cookie + , cookie_value = setCookieValue set_cookie + , cookie_expiry_time = getExpiryTime (setCookieExpires set_cookie) (setCookieMaxAge set_cookie) + , cookie_domain = domain_final + , cookie_path = getPath $ setCookiePath set_cookie + , cookie_creation_time = now + , cookie_last_access_time = now + , cookie_persistent = getPersistent + , cookie_host_only = host_only' + , cookie_secure_only = setCookieSecure set_cookie + , cookie_http_only = http_only' + } + where sanitizeDomain domain' + | has_a_character && BS.singleton (BS.last domain') == "." = Nothing + | has_a_character && BS.singleton (BS.head domain') == "." = Just $ BS.tail domain' + | otherwise = Just $ domain' + where has_a_character = not (BS.null domain') + step4 (Just set_cookie_domain) = set_cookie_domain + step4 Nothing = BS.empty + step5 domain' + | firstCondition && domain' == (Req.host request) = return BS.empty + | firstCondition = Nothing + | otherwise = return 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) + | otherwise = return (Req.host request, True) + where firstCondition = not $ BS.null domain' + step10 + | not is_http_api && setCookieHttpOnly set_cookie = Nothing + | otherwise = return $ setCookieHttpOnly set_cookie + getExpiryTime :: Maybe UTCTime -> Maybe DiffTime -> UTCTime + getExpiryTime _ (Just t) = (fromRational $ toRational t) `addUTCTime` now + getExpiryTime (Just t) Nothing = t + getExpiryTime Nothing Nothing = UTCTime (365000 `addDays` utctDay now) (secondsToDiffTime 0) + getPath (Just p) = p + getPath Nothing = defaultPath request + getPersistent = isJust (setCookieExpires set_cookie) || isJust (setCookieMaxAge set_cookie) diff --git a/Network/HTTP/Client/Core.hs b/Network/HTTP/Client/Core.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Client/Core.hs @@ -0,0 +1,214 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +module Network.HTTP.Client.Core + ( withResponse + , httpLbs + , httpRaw + , responseOpen + , responseClose + , applyCheckStatus + , httpRedirect + ) where + +import Network.HTTP.Types +import Network.HTTP.Client.Manager +import Network.HTTP.Client.Types +import Network.HTTP.Client.Body +import Network.HTTP.Client.Request +import Network.HTTP.Client.Response +import Network.HTTP.Client.Cookies +import Data.Time +import Control.Exception +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString.Lazy as L +import Data.Monoid +import Control.Monad (void) + +-- | Perform a @Request@ using a connection acquired from the given @Manager@, +-- and then provide the @Response@ to the given function. This function is +-- fully exception safe, guaranteeing that the response will be closed when the +-- inner function exits. It is defined as: +-- +-- > withResponse req man f = bracket (responseOpen req man) responseClose f +-- +-- It is recommended that you use this function in place of explicit calls to +-- 'responseOpen' and 'responseClose'. +-- +-- You will need to use functions such as 'brRead' to consume the response +-- body. +-- +-- Since 0.1.0 +withResponse :: Request + -> Manager + -> (Response BodyReader -> IO a) + -> IO a +withResponse req man f = bracket (responseOpen req man) responseClose f + +-- | A convenience wrapper around 'withResponse' which reads in the entire +-- response body and immediately closes the connection. Note that this function +-- performs fully strict I\/O, and only uses a lazy ByteString in its response +-- for memory efficiency. If you are anticipating a large response body, you +-- are encouraged to use 'withResponse' and 'brRead' instead. +-- +-- Since 0.1.0 +httpLbs :: Request -> Manager -> IO (Response L.ByteString) +httpLbs req man = withResponse req man $ \res -> do + bss <- brConsume $ responseBody res + return res { responseBody = L.fromChunks bss } + +-- | Get a 'Response' without any redirect following. +httpRaw + :: Request + -> Manager + -> IO (Response BodyReader) +httpRaw req' m = do + (req, cookie_jar') <- case cookieJar req' of + Just cj -> do + now <- getCurrentTime + return $ insertCookiesIntoRequest req' (evictExpiredCookies cj now) now + Nothing -> return (req', mempty) + (timeout', (connRelease, ci, isManaged)) <- getConnectionWrapper + req + (responseTimeout' req) + (failedConnectionException req) + (getConn req m) + + -- Originally, we would only test for exceptions when sending the request, + -- not on calling @getResponse@. However, some servers seem to close + -- connections after accepting the request headers, so we need to check for + -- exceptions in both. + ex <- try $ do + requestBuilder req ci + + getResponse connRelease timeout' req ci + + case (ex, isManaged) of + -- Connection was reused, and might have been closed. Try again + (Left e, Reused) | mRetryableException m e -> do + connRelease DontReuse + responseOpen req m + -- Not reused, or a non-retry, so this is a real exception + (Left e, _) -> 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 res, _) -> case cookieJar req' of + Just _ -> do + now' <- getCurrentTime + let (cookie_jar, _) = updateCookieJar res req now' cookie_jar' + return $ res {responseCookieJar = cookie_jar} + Nothing -> return res + where + + responseTimeout' req + | rt == useDefaultTimeout = mResponseTimeout m + | otherwise = rt + where + rt = responseTimeout req + +-- | The most low-level function for initiating an HTTP request. +-- +-- The first argument to this function gives a full specification +-- on the request: the host to connect to, whether to use SSL, +-- headers, etc. Please see 'Request' for full details. The +-- second argument specifies which 'Manager' should be used. +-- +-- This function then returns a 'Response' with a +-- 'BodyReader'. The 'Response' contains the status code +-- and headers that were sent back to us, and the +-- 'BodyReader' contains the body of the request. Note +-- that this 'BodyReader' allows you to have fully +-- interleaved IO actions during your HTTP download, making it +-- possible to download very large responses in constant memory. +-- +-- An important note: the response body returned by this function represents a +-- live HTTP connection. As such, if you do not use the response body, an open +-- socket will be retained indefinitely. You must be certain to call +-- 'responseClose' on this response to free up resources. +-- +-- This function automatically performs any necessary redirects, as specified +-- by the 'redirectCount' setting. +-- +-- Since 0.1.0 +responseOpen :: Request -> Manager -> IO (Response BodyReader) +responseOpen req0 manager = mWrapIOException manager $ do + res <- + if redirectCount req0 == 0 + then httpRaw req0 manager + else go (redirectCount req0) req0 + maybe (return res) throwIO =<< applyCheckStatus (checkStatus req0) res + where + go count req' = httpRedirect + count + (\req -> do + res <- httpRaw req manager + let mreq = getRedirectedRequest req (responseHeaders res) (responseCookieJar res) (statusCode (responseStatus res)) + return (res, mreq)) + req' + +-- | Apply 'Request'\'s 'checkStatus' and return resulting exception if any. +applyCheckStatus + :: (Status -> ResponseHeaders -> CookieJar -> Maybe SomeException) + -> Response BodyReader + -> IO (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 <- brReadSome (responseBody res) 1024 + return $ toException $ StatusCodeException s (hdrs ++ + [("X-Response-Body-Start", toStrict' lbs)]) cookie_jar + _ -> return exc + responseClose res + return (Just exc') + where +#if MIN_VERSION_bytestring(0,10,0) + toStrict' = L.toStrict +#else + toStrict' = S.concat . L.toChunks +#endif + +-- | Redirect loop +httpRedirect + :: Int -- ^ 'redirectCount' + -> (Request -> IO (Response BodyReader, Maybe Request)) -- ^ function which performs a request and returns a response, and possibly another request if there's a redirect. + -> Request + -> IO (Response BodyReader) +httpRedirect count0 http' req0 = go count0 req0 [] + where + go (-1) _ ress = throwIO . TooManyRedirects =<< mapM lbsResponse ress + go count req' ress = do + (res, mreq) <- http' req' + case mreq of + Just req -> do + {- FIXME + -- Allow the original connection to return to the + -- connection pool immediately by flushing the body. + -- If the response body is too large, don't flush, but + -- instead just close the connection. + let maxFlush = 1024 + readMay bs = + case S8.readInt bs of + Just (i, bs') | S.null bs' -> Just i + _ -> Nothing + case lookup "content-length" (responseHeaders res) >>= readMay of + Just i | i > maxFlush -> return () + _ -> void $ brReadSome (responseBody res) maxFlush + -} + responseClose res + + -- And now perform the actual redirect + go (count - 1) req (res:ress) + Nothing -> return res + +-- | Close any open resources associated with the given @Response@. In general, +-- this will either close an active @Connection@ or return it to the @Manager@ +-- to be reused. +-- +-- Since 0.1.0 +responseClose :: Response a -> IO () +responseClose = runResponseClose . responseClose' diff --git a/Network/HTTP/Client/Headers.hs b/Network/HTTP/Client/Headers.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Client/Headers.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} +module Network.HTTP.Client.Headers + ( parseStatusHeaders + ) where + +import Control.Applicative ((<$>), (<*>)) +import Control.Exception (throwIO) +import Control.Monad +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 +import qualified Data.CaseInsensitive as CI +import Network.HTTP.Client.Connection +import Network.HTTP.Client.Types +import Network.HTTP.Types +import Data.Word (Word8) + +charLF, charCR, charSpace, charColon, charPeriod :: Word8 +charLF = 10 +charCR = 13 +charSpace = 32 +charColon = 58 +charPeriod = 46 + + +parseStatusHeaders :: Connection -> IO StatusHeaders +parseStatusHeaders conn = do + (status, version) <- getStatusLine + headers <- parseHeaders 0 id + return $! StatusHeaders status version headers + where + getStatusLine = do + -- Ensure that there is some data coming in. If not, we want to signal + -- this as a connection problem and not a protocol problem. + bs <- connectionRead conn + when (S.null bs) $ throwIO NoResponseDataReceived + + status@(code, _) <- connectionReadLineWith conn bs >>= parseStatus 3 + if code == status100 + then newline ExpectedBlankAfter100Continue >> getStatusLine + else return status + + newline exc = do + line <- connectionReadLine conn + unless (S.null line) $ throwIO exc + + parseStatus :: Int -> S.ByteString -> IO (Status, HttpVersion) + parseStatus i bs | S.null bs && i > 0 = connectionReadLine conn >>= parseStatus (i - 1) + 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 <*> readInt code of + Just (ver', code') -> return (Status code' msg, ver') + Nothing -> throwIO $ InvalidStatusLine bs + + stripPrefixBS x y + | x `S.isPrefixOf` y = Just $ S.drop (S.length x) y + | otherwise = Nothing + parseVersion bs0 = do + bs1 <- stripPrefixBS "HTTP/" bs0 + let (num1, S.drop 1 -> num2) = S.breakByte charPeriod bs1 + HttpVersion <$> readInt num1 <*> readInt num2 + + readInt bs = + case S8.readInt bs of + Just (i, "") -> Just i + _ -> Nothing + + parseHeaders 100 _ = throwIO OverlongHeaders + parseHeaders count front = do + line <- connectionReadLine conn + if S.null line + then return $ front [] + else do + header <- parseHeader line + parseHeaders (count + 1) $ front . (header:) + + parseHeader :: S.ByteString -> IO Header + parseHeader bs = do + let (key, bs2) = S.breakByte charColon bs + when (S.null bs2) $ throwIO $ InvalidHeader bs + return (CI.mk $! strip key, strip $! S.drop 1 bs2) + + strip = S.dropWhile (== charSpace) . fst . S.spanEnd (== charSpace) diff --git a/Network/HTTP/Client/Internal.hs b/Network/HTTP/Client/Internal.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Client/Internal.hs @@ -0,0 +1,39 @@ +{-# OPTIONS_HADDOCK not-home #-} +-- | Note that this is essentially the \"kitchen sink\" export module, +-- including many functions intended only to be used internally by this +-- package. No API stability is guaranteed for this module. If you see +-- functions here which you believe should be promoted to a stable API, please +-- contact the author. +module Network.HTTP.Client.Internal + ( -- * Low-level response body handling + module Network.HTTP.Client.Body + -- * Raw connection handling + , module Network.HTTP.Client.Connection + -- * Cookies + , module Network.HTTP.Client.Cookies + -- * Performing requests + , module Network.HTTP.Client.Core + -- * Parse response headers + , module Network.HTTP.Client.Headers + -- * Request helper functions + , module Network.HTTP.Client.Request + -- * Low-level response body handling + , module Network.HTTP.Client.Response + -- * Manager + , module Network.HTTP.Client.Manager + -- * All types + , module Network.HTTP.Client.Types + -- * Various utilities + , module Network.HTTP.Client.Util + ) where + +import Network.HTTP.Client.Body +import Network.HTTP.Client.Connection +import Network.HTTP.Client.Cookies +import Network.HTTP.Client.Core +import Network.HTTP.Client.Headers +import Network.HTTP.Client.Manager +import Network.HTTP.Client.Request +import Network.HTTP.Client.Response +import Network.HTTP.Client.Types +import Network.HTTP.Client.Util diff --git a/Network/HTTP/Client/Manager.hs b/Network/HTTP/Client/Manager.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Client/Manager.hs @@ -0,0 +1,319 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE RankNTypes #-} +module Network.HTTP.Client.Manager + ( ManagerSettings (..) + , newManager + , closeManager + , getConn + , failedConnectionException + , defaultManagerSettings + ) where + +#if !MIN_VERSION_base(4,6,0) +import Prelude hiding (catch) +#endif +import Data.Monoid (mappend) +import System.IO (hClose, hFlush, IOMode(..)) +import qualified Data.IORef as I +import qualified Data.Map as Map + +import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString.Lazy as L + +import qualified Blaze.ByteString.Builder as Blaze + +import Data.Text (Text) +import qualified Data.Text as T + +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Exception (mask_, SomeException, catch, throwIO, fromException, mask, IOException, Exception (..), handle) +import Control.Concurrent (forkIO, threadDelay) +import Data.Time (UTCTime (..), Day (..), DiffTime, getCurrentTime, addUTCTime) +import Control.DeepSeq (deepseq) + +import qualified Network.Socket as NS + +import Data.Default +import Data.Maybe (mapMaybe) +import System.IO (Handle) +import System.Mem.Weak (Weak, deRefWeak) +import Network.HTTP.Client.Types +import Network.HTTP.Client.Connection + +-- | Default value for @ManagerSettings@. +-- +-- Since 0.1.0 +defaultManagerSettings :: ManagerSettings +defaultManagerSettings = ManagerSettings + { managerConnCount = 10 + , managerRawConnection = return openSocketConnection + , managerTlsConnection = return $ \_ _ _ -> throwIO TlsNotSupported + , managerResponseTimeout = Just 5000000 + , managerRetryableException = \e -> + case fromException e of + Just (_ :: IOException) -> True + _ -> + case fromException e of + -- Note: Some servers will timeout connections by accepting + -- the incoming packets for the new request, but closing + -- the connection as soon as we try to read. To make sure + -- we open a new connection under these circumstances, we + -- check for the NoResponseDataReceived exception. + Just NoResponseDataReceived -> True + _ -> False + , managerWrapIOException = + let wrapper se = + case fromException se of + Just e -> toException $ InternalIOException e + Nothing -> se + in handle $ throwIO . wrapper + } + +takeSocket :: Manager -> ConnKey -> IO (Maybe Connection) +takeSocket man key = + I.atomicModifyIORef (mConns man) go + where + go Nothing = (Nothing, Nothing) + go (Just m) = + case Map.lookup key m of + Nothing -> (Just m, Nothing) + Just (One a _) -> (Just $ Map.delete key m, Just a) + Just (Cons a _ _ rest) -> (Just $ Map.insert key rest m, Just a) + +putSocket :: Manager -> ConnKey -> Connection -> IO () +putSocket man key ci = do + now <- getCurrentTime + msock <- I.atomicModifyIORef (mConns man) (go now) + maybe (return ()) connectionClose msock + where + go _ Nothing = (Nothing, Just ci) + go now (Just m) = + case Map.lookup key m of + Nothing -> (Just $ Map.insert key (One ci now) m, Nothing) + Just l -> + let (l', mx) = addToList now (mMaxConns man) ci l + in (Just $ Map.insert key l' m, mx) + +-- | Add a new element to the list, up to the given maximum number. If we're +-- already at the maximum, return the new value as leftover. +addToList :: UTCTime -> Int -> a -> NonEmptyList a -> (NonEmptyList a, Maybe a) +addToList _ i x l | i <= 1 = (l, Just x) +addToList now _ x l@One{} = (Cons x 2 now l, Nothing) +addToList now maxCount x l@(Cons _ currCount _ _) + | maxCount > currCount = (Cons x (currCount + 1) now l, Nothing) + | otherwise = (l, Just x) + +-- | Create a 'Manager'. You may manually call 'closeManager' to shut it down, +-- or allow the @Manager@ to be shut down automatically based on garbage +-- collection. +-- +-- Creating a new 'Manager' is a relatively expensive operation, you are +-- advised to share a single 'Manager' between requests instead. +-- +-- The first argument to this function is often 'defaultManagerSettings', +-- though add-on libraries may provide a recommended replacement. +-- +-- Since 0.1.0 +newManager :: ManagerSettings -> IO Manager +newManager ms = do + rawConnection <- managerRawConnection ms + tlsConnection <- managerTlsConnection ms + mapRef <- I.newIORef (Just Map.empty) + wmapRef <- I.mkWeakIORef mapRef $ closeManager' mapRef + _ <- forkIO $ reap wmapRef + let manager = Manager + { mConns = mapRef + , mMaxConns = managerConnCount ms + , mResponseTimeout = managerResponseTimeout ms + , mRawConnection = rawConnection + , mTlsConnection = tlsConnection + , mRetryableException = managerRetryableException ms + , mWrapIOException = managerWrapIOException ms + } + return manager + +-- | Collect and destroy any stale connections. +reap :: Weak (I.IORef (Maybe (Map.Map ConnKey (NonEmptyList Connection)))) + -> IO () +reap wmapRef = + mask_ loop + where + loop = do + threadDelay (5 * 1000 * 1000) + mmapRef <- deRefWeak wmapRef + case mmapRef of + Nothing -> return () -- manager is closed + Just mapRef -> goMapRef mapRef + + goMapRef mapRef = do + now <- getCurrentTime + let isNotStale time = 30 `addUTCTime` time >= now + mtoDestroy <- I.atomicModifyIORef mapRef (findStaleWrap isNotStale) + case mtoDestroy of + Nothing -> return () -- manager is closed + Just toDestroy -> do + mapM_ safeConnClose toDestroy + loop + findStaleWrap _ Nothing = (Nothing, Nothing) + findStaleWrap isNotStale (Just m) = + let (x, y) = findStale isNotStale m + in (Just x, Just y) + findStale isNotStale = + findStale' id id . Map.toList + where + findStale' destroy keep [] = (Map.fromList $ keep [], destroy []) + findStale' destroy keep ((connkey, nelist):rest) = + findStale' destroy' keep' rest + where + -- Note: By definition, the timestamps must be in descending order, + -- so we don't need to traverse the whole list. + (notStale, stale) = span (isNotStale . fst) $ neToList nelist + destroy' = destroy . (map snd stale++) + keep' = + case neFromList notStale of + Nothing -> keep + Just x -> keep . ((connkey, x):) + + flushStaleCerts now = + Map.fromList . mapMaybe flushStaleCerts' . Map.toList + where + flushStaleCerts' (host', inner) = + case mapMaybe flushStaleCerts'' $ Map.toList inner of + [] -> Nothing + pairs -> + let x = take 10 pairs + in x `seqPairs` Just (host', Map.fromList x) + flushStaleCerts'' (certs, expires) + | expires > now = Just (certs, expires) + | otherwise = Nothing + + seqPairs :: [(L.ByteString, UTCTime)] -> b -> b + seqPairs [] b = b + seqPairs (p:ps) b = p `seqPair` ps `seqPairs` b + + seqPair :: (L.ByteString, UTCTime) -> b -> b + seqPair (lbs, utc) b = lbs `seqLBS` utc `seqUTC` b + + seqLBS :: L.ByteString -> b -> b + seqLBS lbs b = L.length lbs `seq` b + + seqUTC :: UTCTime -> b -> b + seqUTC (UTCTime day dt) b = day `seqDay` dt `seqDT` b + + seqDay :: Day -> b -> b + seqDay (ModifiedJulianDay i) b = i `deepseq` b + + seqDT :: DiffTime -> b -> b + seqDT = seq + +neToList :: NonEmptyList a -> [(UTCTime, a)] +neToList (One a t) = [(t, a)] +neToList (Cons a _ t nelist) = (t, a) : neToList nelist + +neFromList :: [(UTCTime, a)] -> Maybe (NonEmptyList a) +neFromList [] = Nothing +neFromList [(t, a)] = Just (One a t) +neFromList xs = + Just . snd . go $ xs + where + go [] = error "neFromList.go []" + go [(t, a)] = (2, One a t) + go ((t, a):rest) = + let (i, rest') = go rest + i' = i + 1 + in i' `seq` (i', Cons a i t rest') + +-- | Close all connections in a 'Manager'. +-- +-- Note that this doesn't affect currently in-flight connections, +-- meaning you can safely use it without hurting any queries you may +-- have concurrently running. +-- +-- Since 0.1.0 +closeManager :: Manager -> IO () +closeManager = closeManager' . mConns + +closeManager' :: I.IORef (Maybe (Map.Map ConnKey (NonEmptyList Connection))) + -> IO () +closeManager' connsRef = mask_ $ do + m <- I.atomicModifyIORef connsRef $ \x -> (Nothing, x) + mapM_ (nonEmptyMapM_ safeConnClose) $ maybe [] Map.elems m + +safeConnClose :: Connection -> IO () +safeConnClose ci = connectionClose ci `catch` \(_::SomeException) -> return () + +nonEmptyMapM_ :: Monad m => (a -> m ()) -> NonEmptyList a -> m () +nonEmptyMapM_ f (One x _) = f x +nonEmptyMapM_ f (Cons x _ _ l) = f x >> nonEmptyMapM_ f l + +-- | 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 +-- either released or returned to the manager. +getManagedConn + :: Manager + -> ConnKey + -> IO Connection + -> IO (ConnRelease, Connection, ManagedConn) +-- We want to avoid any holes caused by async exceptions, so let's mask. +getManagedConn man key open = mask $ \restore -> do + -- Try to take the socket out of the manager. + mci <- takeSocket man key + (ci, isManaged) <- + case mci of + -- There wasn't a matching connection in the manager, so create a + -- new one. + Nothing -> do + ci <- restore open + return (ci, Fresh) + -- Return the existing one + Just ci -> return (ci, Reused) + + -- When we release this connection, we can either reuse it (put it back in + -- the manager) or not reuse it (close the socket). We set up a mutable + -- reference to track what we want to do. By default, we say not to reuse + -- it, that way if an exception is thrown, the connection won't be reused. + toReuseRef <- I.newIORef DontReuse + + -- When the connection is explicitly released, we update our toReuseRef to + -- indicate what action should be taken, and then call release. + let connRelease Reuse = putSocket man key ci + connRelease DontReuse = connectionClose ci + + return (connRelease, ci, isManaged) + +-- | Create an exception to be thrown if the connection for the given request +-- fails. +failedConnectionException :: Request -> HttpException +failedConnectionException req = + FailedConnectionException host' port' + where + (_, host', port') = getConnDest req + +getConnDest :: Request -> (Bool, String, Int) +getConnDest req = + case proxy req of + Just p -> (True, S8.unpack (proxyHost p), proxyPort p) + Nothing -> (False, S8.unpack $ host req, port req) + +getConn :: Request + -> Manager + -> IO (ConnRelease, Connection, ManagedConn) +getConn req m = + getManagedConn m (ConnKey connKeyHost connport (secure req)) $ + go connaddr connhost connport + where + h = host req + (useProxy, connhost, connport) = getConnDest req + (connaddr, connKeyHost) = + case (hostAddress req, useProxy{-, socksProxy req-}) of + (Just ha, False{-, Nothing-}) -> (Just ha, HostAddress ha) + _ -> (Nothing, HostName $ T.pack connhost) + go = + case (secure req, useProxy) of + (False, _) -> mRawConnection m + (True, False) -> mTlsConnection m + -- FIXME (True, True) -> getSslProxyConn (checkCerts m h) (clientCertificates req) h (port req) diff --git a/Network/HTTP/Client/Request.hs b/Network/HTTP/Client/Request.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Client/Request.hs @@ -0,0 +1,352 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Network.HTTP.Client.Request + ( parseUrl + , setUriRelative + , getUri + , setUri + , browserDecompress + , alwaysDecompress + , addProxy + , applyBasicAuth + , urlEncodedBody + , needsGunzip + , requestBuilder + , useDefaultTimeout + ) where + +import Data.Maybe (fromMaybe, isJust) +import Data.Monoid (mempty, mappend) +import Data.String (IsString(..)) +import Control.Monad (when, unless) +import Numeric (showHex) + +import Data.Default (Default (def)) + +import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString, toByteStringIO) +import Blaze.ByteString.Builder.Char8 (fromChar) + +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString.Lazy as L + +import qualified Network.HTTP.Types as W +import Network.URI (URI (..), URIAuth (..), parseURI, relativeTo, escapeURIString, isAllowedInURI) + +import Control.Monad.IO.Class (liftIO) +import Control.Exception (Exception, toException, throw, throwIO) +import Control.Failure (Failure (failure)) +import qualified Data.CaseInsensitive as CI +import qualified Data.ByteString.Base64 as B64 + +import Network.HTTP.Client.Types +import Network.HTTP.Client.Connection + +import Network.HTTP.Client.Util (readDec, (<>)) +import System.Timeout (timeout) +import Data.Time.Clock + +-- | Convert a URL into a 'Request'. +-- +-- This defaults some of the values in 'Request', such as setting 'method' to +-- GET and 'requestHeaders' to @[]@. +-- +-- Since this function uses 'Failure', the return monad can be anything that is +-- an instance of 'Failure', such as 'IO' or 'Maybe'. +-- +-- Since 0.1.0 +parseUrl :: Failure HttpException m => String -> m Request +parseUrl s = + case parseURI (encode s) of + Just uri -> setUri def uri + Nothing -> failure $ InvalidUrlException s "Invalid URL" + where + encode = escapeURIString isAllowedInURI + +-- | Add a 'URI' to the request. If it is absolute (includes a host name), add +-- it as per 'setUri'; if it is relative, merge it with the existing request. +setUriRelative :: Failure HttpException m => Request -> URI -> m Request +setUriRelative req uri = +#if MIN_VERSION_network(2,4,0) + setUri req $ uri `relativeTo` getUri req +#else + case uri `relativeTo` getUri req of + Just uri' -> setUri req uri' + Nothing -> failure $ InvalidUrlException (show uri) "Invalid URL" +#endif + +-- | Extract a 'URI' from the request. +-- +-- Since 0.1.0 +getUri :: Request -> URI +getUri req = URI + { uriScheme = if secure req + then "https:" + else "http:" + , uriAuthority = Just URIAuth + { uriUserInfo = "" + , uriRegName = S8.unpack $ host req + , uriPort = ':' : show (port req) + } + , uriPath = S8.unpack $ path req + , uriQuery = S8.unpack $ queryString req + , uriFragment = "" + } + +-- | Validate a 'URI', then add it to the request. +setUri :: Failure HttpException m => Request -> URI -> m Request +setUri req uri = do + sec <- parseScheme uri + auth <- maybe (failUri "URL must be absolute") return $ uriAuthority uri + if not . null $ uriUserInfo auth + then failUri "URL auth not supported; use applyBasicAuth instead" + else return () + port' <- parsePort sec auth + return req + { host = S8.pack $ uriRegName auth + , port = port' + , secure = sec + , path = S8.pack $ + if null $ uriPath uri + then "/" + else uriPath uri + , queryString = S8.pack $ uriQuery uri + } + where + failUri :: Failure HttpException m => String -> m a + failUri = failure . InvalidUrlException (show uri) + + parseScheme URI{uriScheme = scheme} = + case scheme of + "http:" -> return False + "https:" -> return True + _ -> failUri "Invalid scheme" + + parsePort sec URIAuth{uriPort = portStr} = + case portStr of + -- If the user specifies a port, then use it + ':':rest -> maybe + (failUri "Invalid port") + return + (readDec rest) + -- Otherwise, use the default port + _ -> case sec of + False {- HTTP -} -> return 80 + True {- HTTPS -} -> return 443 + +instance Show Request where + show x = unlines + [ "Request {" + , " host = " ++ show (host x) + , " port = " ++ show (port x) + , " secure = " ++ show (secure x) + , " requestHeaders = " ++ show (requestHeaders x) + , " path = " ++ show (path x) + , " queryString = " ++ show (queryString x) + --, " requestBody = " ++ show (requestBody x) + , " method = " ++ show (method x) + , " proxy = " ++ show (proxy x) + , " rawBody = " ++ show (rawBody x) + , " redirectCount = " ++ show (redirectCount x) + , " responseTimeout = " ++ show (responseTimeout x) + , "}" + ] + +-- | Magic value to be placed in a 'Request' to indicate that we should use the +-- timeout value in the @Manager@. +-- +-- Since 1.9.3 +useDefaultTimeout :: Maybe Int +useDefaultTimeout = Just (-3425) + +instance Default Request where + def = Request + { host = "localhost" + , port = 80 + , secure = False + , requestHeaders = [] + , path = "/" + , queryString = S8.empty + , requestBody = RequestBodyLBS L.empty + , method = "GET" + , proxy = Nothing + , hostAddress = Nothing + , rawBody = False + , decompress = browserDecompress + , redirectCount = 10 + , checkStatus = \s@(W.Status sci _) hs cookie_jar -> + if 200 <= sci && sci < 300 + then Nothing + else Just $ toException $ StatusCodeException s hs cookie_jar + , responseTimeout = useDefaultTimeout + , getConnectionWrapper = \mtimeout exc f -> + case mtimeout of + Nothing -> fmap ((,) Nothing) f + Just timeout' -> do + before <- getCurrentTime + mres <- timeout timeout' f + case mres of + Nothing -> throwIO exc + Just res -> do + now <- getCurrentTime + let timeSpentMicro = diffUTCTime now before * 1000000 + remainingTime = round $ fromIntegral timeout' - timeSpentMicro + if remainingTime <= 0 + then throwIO exc + else return (Just remainingTime, res) + , cookieJar = Just def + } + +instance IsString Request where + fromString s = + case parseUrl s of + Left e -> throw (e :: HttpException) + Right r -> r + +-- | Always decompress a compressed stream. +alwaysDecompress :: S.ByteString -> Bool +alwaysDecompress = const True + +-- | Decompress a compressed stream unless the content-type is 'application/x-tar'. +browserDecompress :: S.ByteString -> Bool +browserDecompress = (/= "application/x-tar") + +-- | Add a Basic Auth header (with the specified user name and password) to the +-- given Request. Ignore error handling: +-- +-- > applyBasicAuth "user" "pass" $ fromJust $ parseUrl url +-- +-- Since 0.1.0 +applyBasicAuth :: S.ByteString -> S.ByteString -> Request -> Request +applyBasicAuth user passwd req = + req { requestHeaders = authHeader : requestHeaders req } + where + authHeader = (CI.mk "Authorization", basic) + basic = S8.append "Basic " (B64.encode $ S8.concat [ user, ":", passwd ]) + + +-- | Add a proxy to the Request so that the Request when executed will use +-- the provided proxy. +-- +-- Since 0.1.0 +addProxy :: S.ByteString -> Int -> Request -> Request +addProxy hst prt req = + req { proxy = Just $ Proxy hst prt } + +-- | Add url-encoded parameters to the 'Request'. +-- +-- This sets a new 'requestBody', adds a content-type request header and +-- changes the 'method' to POST. +-- +-- Since 0.1.0 +urlEncodedBody :: [(S.ByteString, S.ByteString)] -> Request -> Request +urlEncodedBody headers req = req + { requestBody = RequestBodyLBS body + , method = "POST" + , requestHeaders = + (ct, "application/x-www-form-urlencoded") + : filter (\(x, _) -> x /= ct) (requestHeaders req) + } + where + ct = "Content-Type" + body = L.fromChunks . return $ W.renderSimpleQuery False headers + +needsGunzip :: Request + -> [W.Header] -- ^ response headers + -> Bool +needsGunzip req hs' = + not (rawBody req) + && ("content-encoding", "gzip") `elem` hs' + && decompress req (fromMaybe "" $ lookup "content-type" hs') + +requestBuilder :: Request -> Connection -> IO () +requestBuilder req Connection {..} = + bodySource + where + writeBuilder = toByteStringIO connectionWrite + + (contentLength, bodySource) = + case requestBody req of + RequestBodyLBS lbs -> (Just $ L.length lbs, writeBuilder $ builder `mappend` fromLazyByteString lbs) + RequestBodyBS bs -> (Just $ fromIntegral $ S.length bs, writeBuilder $ builder `mappend` fromByteString bs) + RequestBodyBuilder i b -> (Just $ i, writeBuilder $ builder `mappend` b) + RequestBodyStream i stream -> (Just i, writeBuilder builder >> writeStream False stream) + RequestBodyStreamChunked stream -> (Nothing, writeBuilder builder >> writeStream True stream) + + writeStream isChunked withStream = + withStream loop + where + loop stream = do + bs <- stream + when isChunked $ + connectionWrite $ S8.pack $ showHex (S.length bs) (if S.null bs then "\r\n\r\n" else "\r\n") + unless (S.null bs) $ do + connectionWrite bs + when isChunked $ connectionWrite "\r\n" + loop stream + + + hh + | port req == 80 && not (secure req) = host req + | port req == 443 && secure req = host req + | otherwise = host req <> S8.pack (':' : show (port req)) + + requestProtocol + | secure req = fromByteString "https://" + | otherwise = fromByteString "http://" + + requestHostname + | isJust (proxy req) = requestProtocol <> fromByteString hh + | otherwise = mempty + + contentLengthHeader (Just contentLength') = + if method req `elem` ["GET", "HEAD"] && contentLength' == 0 + then id + else (:) ("Content-Length", S8.pack $ show contentLength') + contentLengthHeader Nothing = (:) ("Transfer-Encoding", "chunked") + + acceptEncodingHeader = + case lookup "Accept-Encoding" $ requestHeaders req of + Nothing -> (("Accept-Encoding", "gzip"):) + Just "" -> filter (\(k, _) -> k /= "Accept-Encoding") + Just _ -> id + + hostHeader x = + case lookup "Host" x of + Nothing -> ("Host", hh) : x + Just{} -> x + + headerPairs :: W.RequestHeaders + headerPairs = hostHeader + $ acceptEncodingHeader + $ contentLengthHeader contentLength + $ requestHeaders req + + builder :: Builder + builder = + fromByteString (method req) + <> fromByteString " " + <> requestHostname + <> (case S8.uncons $ path req of + Just ('/', _) -> fromByteString $ path req + _ -> fromChar '/' <> fromByteString (path req)) + <> (case S8.uncons $ queryString req of + Nothing -> mempty + Just ('?', _) -> fromByteString $ queryString req + _ -> fromChar '?' <> fromByteString (queryString req)) + <> fromByteString " HTTP/1.1\r\n" + <> foldr + (\a b -> headerPairToBuilder a <> b) + (fromByteString "\r\n") + headerPairs + + headerPairToBuilder (k, v) = + fromByteString (CI.original k) + <> fromByteString ": " + <> fromByteString v + <> fromByteString "\r\n" diff --git a/Network/HTTP/Client/Response.hs b/Network/HTTP/Client/Response.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Client/Response.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} +module Network.HTTP.Client.Response + ( getRedirectedRequest + , getResponse + , lbsResponse + ) where + +import Control.Arrow (first) +import Control.Monad (liftM) + +import Control.Exception (throwIO) +import Control.Monad.IO.Class (MonadIO, liftIO) + +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString.Lazy as L + +import qualified Data.CaseInsensitive as CI + +import Data.Default (def) + +import qualified Network.HTTP.Types as W +import Network.URI (parseURIReference) + +import Network.HTTP.Client.Types + +import Network.HTTP.Client.Manager +import Network.HTTP.Client.Request +import Network.HTTP.Client.Util +import Network.HTTP.Client.Body +import Network.HTTP.Client.Headers +import Network.HTTP.Client.Connection + +import System.Timeout (timeout) + +-- | If a request is a redirection (status code 3xx) this function will create +-- a new request from the old request, the server headers returned with the +-- redirection, and the redirection code itself. This function returns 'Nothing' +-- if the code is not a 3xx, there is no 'location' header included, or if the +-- redirected response couldn't be parsed with 'parseUrl'. +-- +-- If a user of this library wants to know the url chain that results from a +-- specific request, that user has to re-implement the redirect-following logic +-- themselves. An example of that might look like this: +-- +-- > 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 -> W.ResponseHeaders -> CookieJar -> Int -> Maybe Request +getRedirectedRequest req hs cookie_jar code + | 300 <= code && code < 400 = do + l' <- lookup "location" hs + req' <- setUriRelative req =<< parseURIReference (S8.unpack l') + return $ + if code == 302 || code == 303 + -- According to the spec, this should *only* be for status code + -- 303. However, almost all clients mistakenly implement it for + -- 302 as well. So we have to be wrong like everyone else... + then req' + { method = "GET" + , requestBody = RequestBodyBS "" + , cookieJar = cookie_jar' + } + 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. +lbsResponse :: Response BodyReader -> IO (Response L.ByteString) +lbsResponse res = do + bss <- brConsume $ responseBody res + return res + { responseBody = L.fromChunks bss + } + +getResponse :: ConnRelease + -> Maybe Int + -> Request + -> Connection + -> IO (Response BodyReader) +getResponse connRelease timeout'' req@(Request {..}) conn = do + let timeout' = + case timeout'' of + Nothing -> id + Just useconds -> \ma -> do + x <- timeout useconds ma + case x of + Nothing -> liftIO $ throwIO ResponseTimeout + Just y -> return y + StatusHeaders s version hs <- timeout' $ parseStatusHeaders conn + let mcl = lookup "content-length" hs >>= readDec . S8.unpack + + -- should we put this connection back into the connection manager? + toPut = Just "close" /= lookup "connection" hs && version > W.HttpVersion 1 0 + cleanup bodyConsumed = connRelease $ if toPut && bodyConsumed then Reuse else DontReuse + + body <- + -- RFC 2616 section 4.4_1 defines responses that must not include a body + if hasNoBody method (W.statusCode s) || mcl == Just 0 + then do + cleanup True + return brEmpty + else do + let isChunked = ("transfer-encoding", "chunked") `elem` hs + body1 <- + if isChunked + then makeChunkedReader rawBody conn + else + case mcl of + Just len -> makeLengthReader len conn + Nothing -> makeUnlimitedReader conn + body2 <- if needsGunzip req hs + then makeGzipReader body1 + else return body1 + return $ brAddCleanup (cleanup True) body2 + + return Response + { responseStatus = s + , responseVersion = version + , responseHeaders = hs + , responseBody = body + , responseCookieJar = def + , responseClose' = ResponseClose (cleanup False) + } diff --git a/Network/HTTP/Client/Types.hs b/Network/HTTP/Client/Types.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Client/Types.hs @@ -0,0 +1,502 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE RankNTypes #-} +module Network.HTTP.Client.Types + ( BodyReader (..) + , Connection (..) + , StatusHeaders (..) + , HttpException (..) + , Cookie (..) + , CookieJar (..) + , Proxy (..) + , RequestBody (..) + , Popper + , NeedsPopper + , GivesPopper + , Request (..) + , ConnReuse (..) + , ConnRelease + , ManagedConn (..) + , Response (..) + , ResponseClose (..) + , Manager (..) + , ManagerSettings (..) + , NonEmptyList (..) + , ConnHost (..) + , ConnKey (..) + ) where + +import qualified Data.Typeable as T (Typeable) +import Network.HTTP.Types +import Control.Exception (Exception, IOException, SomeException) +import Data.Word (Word64) +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import Blaze.ByteString.Builder (Builder, fromLazyByteString, fromByteString, toLazyByteString) +import Data.Int (Int64) +import Data.Default +import Data.Monoid +import Data.Time (UTCTime) +import qualified Data.List as DL +import Network.Socket (HostAddress) +import Data.IORef +import qualified Network.Socket as NS +import qualified Data.IORef as I +import qualified Data.Map as Map +import Data.Text (Text) + +-- | An abstraction for representing an incoming response body coming from the +-- server. Data provided by this abstraction has already been gunzipped and +-- de-chunked, and respects any content-length headers present. +-- +-- Since 0.1.0 +data BodyReader = BodyReader + { brRead :: !(IO S.ByteString) + -- ^ Get a single chunk of data from the response body, or an empty + -- bytestring if no more data is available. + -- + -- Since 0.1.0 + , brComplete :: !(IO Bool) + } + +data Connection = Connection + { connectionRead :: !(IO S.ByteString) + -- ^ If no more data, return empty. + , connectionUnread :: !(S.ByteString -> IO ()) + -- ^ Return data to be read next time. + , connectionWrite :: !(S.ByteString -> IO ()) + -- ^ Send data to server + , connectionClose :: !(IO ()) + } + +data StatusHeaders = StatusHeaders !Status !HttpVersion !RequestHeaders + deriving (Show, Eq, Ord) + +data HttpException = StatusCodeException Status 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. + | TooManyRetries + | HttpParserException String + | HandshakeFailed + | OverlongHeaders + | ResponseTimeout + | FailedConnectionException String Int -- ^ host/port + | ExpectedBlankAfter100Continue + | InvalidStatusLine S.ByteString + | InvalidHeader S.ByteString + | InternalIOException IOException + | ProxyConnectException S.ByteString Int (Either S.ByteString HttpException) -- ^ host/port + | NoResponseDataReceived + | TlsException SomeException + | TlsNotSupported + | ResponseBodyTooShort Word64 Word64 + -- ^ Expected size/actual size. + -- + -- Since 1.9.4 + | InvalidChunkHeaders + -- ^ + -- + -- Since 1.9.4 + | IncompleteHeaders + deriving (Show, T.Typeable) +instance Exception HttpException + + +-- 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 (Read, Show) + +newtype CookieJar = CJ { expose :: [Cookie] } + deriving (Read, 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 + +-- | Define a HTTP proxy, consisting of a hostname and port number. + +data Proxy = Proxy + { proxyHost :: !S.ByteString -- ^ The host name of the HTTP proxy. + , proxyPort :: !Int -- ^ The port number of the HTTP proxy. + } + deriving (Show, Read, Eq, Ord, T.Typeable) + +-- | When using one of the 'RequestBodyStream' \/ 'RequestBodyStreamChunked' +-- constructors, you must ensure that the 'GivesPopper' can be called multiple +-- times. Usually this is not a problem. +-- +-- The 'RequestBodyStreamChunked' will send a chunked request body. Note that +-- not all servers support this. Only use 'RequestBodyStreamChunked' if you +-- know the server you're sending to supports chunked request bodies. +-- +-- Since 0.1.0 +data RequestBody + = RequestBodyLBS !L.ByteString + | RequestBodyBS !S.ByteString + | RequestBodyBuilder !Int64 !Builder + | RequestBodyStream !Int64 !(GivesPopper ()) + | RequestBodyStreamChunked !(GivesPopper ()) +instance Monoid RequestBody where + mempty = RequestBodyBS S.empty + mappend x0 y0 = + case (simplify x0, simplify y0) of + (Left (i, x), Left (j, y)) -> RequestBodyBuilder (i + j) (x `mappend` y) + (Left x, Right y) -> combine (builderToStream x) y + (Right x, Left y) -> combine x (builderToStream y) + (Right x, Right y) -> combine x y + where + combine (Just i, x) (Just j, y) = RequestBodyStream (i + j) (combine' x y) + combine (_, x) (_, y) = RequestBodyStreamChunked (combine' x y) + + combine' :: GivesPopper () -> GivesPopper () -> GivesPopper () + combine' x y f = x $ \x' -> y $ \y' -> combine'' x' y' f + + combine'' :: Popper -> Popper -> NeedsPopper () -> IO () + combine'' x y f = do + istate <- newIORef $ Left (x, y) + f $ go istate + + go istate = do + state <- readIORef istate + case state of + Left (x, y) -> do + bs <- x + if S.null bs + then do + writeIORef istate $ Right y + y + else return bs + Right y -> y + +simplify :: RequestBody -> Either (Int64, Builder) (Maybe Int64, GivesPopper ()) +simplify (RequestBodyLBS lbs) = Left (L.length lbs, fromLazyByteString lbs) +simplify (RequestBodyBS bs) = Left (fromIntegral $ S.length bs, fromByteString bs) +simplify (RequestBodyBuilder len b) = Left (len, b) +simplify (RequestBodyStream i gp) = Right (Just i, gp) +simplify (RequestBodyStreamChunked gp) = Right (Nothing, gp) + +builderToStream :: (Int64, Builder) -> (Maybe Int64, GivesPopper ()) +builderToStream (len, builder) = + (Just len, gp) + where + gp np = do + ibss <- newIORef $ L.toChunks $ toLazyByteString builder + np $ do + bss <- readIORef ibss + case bss of + [] -> return S.empty + bs:bss' -> do + writeIORef ibss bss' + return bs + +-- | A function which generates successive chunks of a request body, provider a +-- single empty bytestring when no more data is available. +-- +-- Since 0.1.0 +type Popper = IO S.ByteString + +-- | A function which must be provided with a 'Popper'. +-- +-- Since 0.1.0 +type NeedsPopper a = Popper -> IO a + +-- | A function which will provide a 'Popper' to a 'NeedsPopper'. This +-- seemingly convoluted structure allows for creation of request bodies which +-- allocate scarce resources in an exception safe manner. +-- +-- Since 0.1.0 +type GivesPopper a = NeedsPopper a -> IO a + +-- | All information on how to connect to a host and what should be sent in the +-- HTTP request. +-- +-- If you simply wish to download from a URL, see 'parseUrl'. +-- +-- The constructor for this data type is not exposed. Instead, you should use +-- either the 'def' method to retrieve a default instance, or 'parseUrl' to +-- construct from a URL, and then use the records below to make modifications. +-- This approach allows http-client to add configuration options without +-- breaking backwards compatibility. +-- +-- For example, to construct a POST request, you could do something like: +-- +-- > initReq <- parseUrl "http://www.example.com/path" +-- > let req = initReq +-- > { method = "POST" +-- > } +-- +-- For more information, please see +-- . +-- +-- Since 0.1.0 +data Request = Request + { method :: Method + -- ^ HTTP request method, eg GET, POST. + -- + -- Since 0.1.0 + , secure :: Bool + -- ^ Whether to use HTTPS (ie, SSL). + -- + -- Since 0.1.0 + , host :: S.ByteString + -- ^ Requested host name, used for both the IP address to connect to and + -- the @host@ request header. + -- + -- Since 0.1.0 + , port :: Int + -- ^ The port to connect to. Also used for generating the @host@ request header. + -- + -- Since 0.1.0 + , path :: S.ByteString + -- ^ Everything from the host to the query string. + -- + -- Since 0.1.0 + , queryString :: S.ByteString + -- ^ Query string appended to the path. + -- + -- Since 0.1.0 + , requestHeaders :: RequestHeaders + -- ^ Custom HTTP request headers + -- + -- The Content-Length and Transfer-Encoding headers are set automatically + -- by this module, and shall not be added to @requestHeaders@. + -- + -- If not provided by the user, @Host@ will automatically be set based on + -- the @host@ and @port@ fields. + -- + -- Moreover, the Accept-Encoding header is set implicitly to gzip for + -- convenience by default. This behaviour can be overridden if needed, by + -- setting the header explicitly to a different value. In order to omit the + -- Accept-Header altogether, set it to the empty string \"\". If you need an + -- empty Accept-Header (i.e. requesting the identity encoding), set it to a + -- non-empty white-space string, e.g. \" \". See RFC 2616 section 14.3 for + -- details about the semantics of the Accept-Header field. If you request a + -- content-encoding not supported by this module, you will have to decode + -- it yourself (see also the 'decompress' field). + -- + -- Note: Multiple header fields with the same field-name will result in + -- multiple header fields being sent and therefore it\'s the responsibility + -- of the client code to ensure that the rules from RFC 2616 section 4.2 + -- are honoured. + -- + -- Since 0.1.0 + , requestBody :: RequestBody + -- ^ Request body to be sent to the server. + -- + -- Since 0.1.0 + , proxy :: Maybe Proxy + -- ^ Optional HTTP proxy. + -- + -- Since 0.1.0 + , hostAddress :: Maybe HostAddress + -- ^ Optional resolved host address. May not be used by all backends. + -- + -- Since 0.1.0 + , rawBody :: Bool + -- ^ If @True@, a chunked and\/or gzipped body will not be + -- decoded. Use with caution. + -- + -- Since 0.1.0 + , decompress :: S.ByteString -> Bool + -- ^ Predicate to specify whether gzipped data should be + -- decompressed on the fly (see 'alwaysDecompress' and + -- 'browserDecompress'). Argument is the mime type. + -- Default: browserDecompress. + -- + -- Since 0.1.0 + , redirectCount :: Int + -- ^ How many redirects to follow when getting a resource. 0 means follow + -- no redirects. Default value: 10. + -- + -- Since 0.1.0 + , checkStatus :: Status -> 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. + -- + -- Since 0.1.0 + , responseTimeout :: Maybe Int + -- ^ Number of microseconds to wait for a response. If @Nothing@, will wait + -- indefinitely. Default: 5 seconds. + -- + -- Since 0.1.0 + , getConnectionWrapper :: Maybe Int + -> HttpException + -> IO (ConnRelease, Connection, ManagedConn) + -> IO (Maybe Int, (ConnRelease, Connection, ManagedConn)) + -- ^ Wraps the calls for getting new connections. This can be useful for + -- instituting some kind of timeouts. The first argument is the value of + -- @responseTimeout@. Second argument is the exception to be thrown on + -- failure. + -- + -- Default: If @responseTimeout@ is @Nothing@, does nothing. Otherwise, + -- institutes timeout, and returns remaining time for @responseTimeout@. + -- + -- Since 0.1.0 + , 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 0.1.0 + } + +data ConnReuse = Reuse | DontReuse + +type ConnRelease = ConnReuse -> IO () + +data ManagedConn = Fresh | Reused + +-- | A simple representation of the HTTP response. +-- +-- Since 0.1.0 +data Response body = Response + { responseStatus :: !Status + -- ^ Status code of the response. + -- + -- Since 0.1.0 + , responseVersion :: !HttpVersion + -- ^ HTTP version used by the server. + -- + -- Since 0.1.0 + , responseHeaders :: !ResponseHeaders + -- ^ Response headers sent by the server. + -- + -- Since 0.1.0 + , responseBody :: !body + -- ^ Response body sent by the server. + -- + -- Since 0.1.0 + , 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. + -- + -- Since 0.1.0 + , responseClose' :: !ResponseClose + -- ^ Releases any resource held by this response. If the response body + -- has not been fully read yet, doing so after this call will likely + -- be impossible. + -- + -- Since 0.1.0 + } + deriving (Show, Eq, T.Typeable, Functor) + +newtype ResponseClose = ResponseClose { runResponseClose :: IO () } + deriving T.Typeable +instance Show ResponseClose where + show _ = "ResponseClose" +instance Eq ResponseClose where + _ == _ = True + +-- | Settings for a @Manager@. Please use the 'defaultManagerSettings' function and then modify +-- individual settings. For more information, see . +-- +-- Since 0.1.0 +data ManagerSettings = ManagerSettings + { managerConnCount :: !Int + -- ^ Number of connections to a single host to keep alive. Default: 10. + -- + -- Since 0.1.0 + , managerRawConnection :: !(IO (Maybe NS.HostAddress -> String -> Int -> IO Connection)) + -- ^ Create an insecure connection. + -- + -- Since 0.1.0 + , managerTlsConnection :: !(IO (Maybe NS.HostAddress -> String -> Int -> IO Connection)) + -- ^ Create a TLS connection. Default behavior: throw an exception that TLS is not supported. + -- + -- Since 0.1.0 + , managerResponseTimeout :: !(Maybe Int) + -- ^ Default timeout (in microseconds) to be applied to requests which do + -- not provide a timeout value. + -- + -- Default is 5 seconds + -- + -- Since 0.1.0 + , managerRetryableException :: !(SomeException -> Bool) + -- ^ Exceptions for which we should retry our request if we were reusing an + -- already open connection. In the case of IOExceptions, for example, we + -- assume that the connection was closed on the server and therefore open a + -- new one. + -- + -- Since 0.1.0 + , managerWrapIOException :: !(forall a. IO a -> IO a) + -- ^ Action wrapped around all attempted @Request@s, usually used to wrap + -- up exceptions in library-specific types. + -- + -- Default: wrap all @IOException@s in the @InternalIOException@ constructor. + -- + -- Since 0.1.0 + } + +-- | Keeps track of open connections for keep-alive. +-- +-- If possible, you should share a single 'Manager' between multiple threads and requests. +-- +-- Since 0.1.0 +data Manager = Manager + { mConns :: !(I.IORef (Maybe (Map.Map ConnKey (NonEmptyList Connection)))) + -- ^ @Nothing@ indicates that the manager is closed. + , mMaxConns :: !Int + -- ^ This is a per-@ConnKey@ value. + , mResponseTimeout :: !(Maybe Int) + -- ^ Copied from 'managerResponseTimeout' + , mRawConnection :: !(Maybe NS.HostAddress -> String -> Int -> IO Connection) + , mTlsConnection :: !(Maybe NS.HostAddress -> String -> Int -> IO Connection) + , mRetryableException :: !(SomeException -> Bool) + , mWrapIOException :: !(forall a. IO a -> IO a) + } + +data NonEmptyList a = + One !a !UTCTime | + Cons !a !Int !UTCTime !(NonEmptyList a) + +-- | Hostname or resolved host address. +data ConnHost = + HostName !Text | + HostAddress !NS.HostAddress + deriving (Eq, Show, Ord) + +-- | @ConnKey@ consists of a hostname, a port and a @Bool@ +-- specifying whether to use SSL. +data ConnKey = ConnKey !ConnHost !Int !Bool + deriving (Eq, Show, Ord) diff --git a/Network/HTTP/Client/Util.hs b/Network/HTTP/Client/Util.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Client/Util.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +module Network.HTTP.Client.Util + ( hGetSome + , (<>) + , readDec + , hasNoBody + , fromStrict + ) where + +import Data.Monoid (Monoid, mappend) + +import qualified Data.ByteString.Char8 as S8 +#if MIN_VERSION_bytestring(0,10,0) +import Data.ByteString.Lazy (fromStrict) +#else +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString as S +#endif + +import qualified Data.Text as T +import qualified Data.Text.Read + +#if MIN_VERSION_base(4,3,0) +import Data.ByteString (hGetSome) +#else +import GHC.IO.Handle.Types +import System.IO (hWaitForInput, hIsEOF) +import System.IO.Error (mkIOError, illegalOperationErrorType) + +-- | Like 'hGet', except that a shorter 'ByteString' may be returned +-- if there are not enough bytes immediately available to satisfy the +-- whole request. 'hGetSome' only blocks if there is no data +-- available, and EOF has not yet been reached. +hGetSome :: Handle -> Int -> IO S.ByteString +hGetSome hh i + | i > 0 = let + loop = do + s <- S.hGetNonBlocking hh i + if not (S.null s) + then return s + else do eof <- hIsEOF hh + if eof then return s + else hWaitForInput hh (-1) >> loop + -- for this to work correctly, the + -- Handle should be in binary mode + -- (see GHC ticket #3808) + in loop + | i == 0 = return S.empty + | otherwise = illegalBufferSize hh "hGetSome" i + +illegalBufferSize :: Handle -> String -> Int -> IO a +illegalBufferSize handle fn sz = + ioError (mkIOError illegalOperationErrorType msg (Just handle) Nothing) + --TODO: System.IO uses InvalidArgument here, but it's not exported :-( + where + msg = fn ++ ": illegal ByteString size " ++ showsPrec 9 sz [] +#endif + +infixr 5 <> +(<>) :: Monoid m => m -> m -> m +(<>) = mappend + +readDec :: Integral i => String -> Maybe i +readDec s = + case Data.Text.Read.decimal $ T.pack s of + Right (i, t) + | T.null t -> Just i + _ -> Nothing + +hasNoBody :: S8.ByteString -- ^ request method + -> Int -- ^ status code + -> Bool +hasNoBody "HEAD" _ = True +hasNoBody _ 204 = True +hasNoBody _ 304 = True +hasNoBody _ i = 100 <= i && i < 200 + +#if !MIN_VERSION_bytestring(0,10,0) +{-# INLINE fromStrict #-} +fromStrict :: S.ByteString -> L.ByteString +fromStrict x = L.fromChunks [x] +#endif diff --git a/http-client.cabal b/http-client.cabal --- a/http-client.cabal +++ b/http-client.cabal @@ -1,9 +1,7 @@ name: http-client -version: 0.1.0.0 +version: 0.2.0.0 synopsis: An HTTP client engine, intended as a base layer for more user-friendly packages. description: This codebase has been refactored from http-conduit. - . - Note that, in its current state, this library is a preview release. It passes tests and seems to work correctly, but has not received a huge level of battle testing yet. I would recommend sticking with http-conduit for production usage until this library has been more thoroughly tested. homepage: https://github.com/snoyberg/http-client license: MIT license-file: LICENSE @@ -16,33 +14,34 @@ library exposed-modules: Network.HTTP.Client - Network.HTTP.Client.Util - Network.HTTP.Client.Types - Network.HTTP.Client.Body - Network.HTTP.Client.Manager + Network.HTTP.Client.Internal + other-modules: Network.HTTP.Client.Body + Network.HTTP.Client.Connection + Network.HTTP.Client.Cookies + Network.HTTP.Client.Core Network.HTTP.Client.Headers + Network.HTTP.Client.Manager Network.HTTP.Client.Request Network.HTTP.Client.Response - Network.HTTP.Client.Connection - Network.HTTP.Client.Cookies - build-depends: base >=4.5 && < 5 - , bytestring >=0.9 - , text >=0.11 - , http-types >=0.8 - , blaze-builder >=0.3 + Network.HTTP.Client.Types + Network.HTTP.Client.Util + build-depends: base >= 4.5 && < 5 + , bytestring >= 0.9 + , text >= 0.11 + , http-types >= 0.8 + , blaze-builder >= 0.3 , data-default - , time >=1.2 - , network >=2.3 - , zlib-bindings >=0.1 && <0.2 + , time >= 1.2 + , network >= 2.3 + , zlib-bindings >= 0.1 && <0.2 , containers , transformers - , deepseq >=1.3 && <1.4 - , case-insensitive >=1.1 && <1.2 - , failure >=0.2 && <0.3 - , base64-bytestring >=1.0 && <1.1 + , deepseq >= 1.3 && <1.4 + , case-insensitive >= 1.1 && <1.2 + , failure >= 0.2 && <0.3 + , base64-bytestring >= 1.0 && <1.1 , publicsuffixlist , cookie - hs-source-dirs: src default-language: Haskell2010 test-suite spec diff --git a/src/Network/HTTP/Client.hs b/src/Network/HTTP/Client.hs deleted file mode 100644 --- a/src/Network/HTTP/Client.hs +++ /dev/null @@ -1,199 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -module Network.HTTP.Client where - -import Network.HTTP.Types -import Network.HTTP.Client.Manager -import Network.HTTP.Client.Types -import Network.HTTP.Client.Body -import Network.HTTP.Client.Request -import Network.HTTP.Client.Response -import Network.HTTP.Client.Cookies -import Data.Time -import Control.Exception -import qualified Data.ByteString as S -import qualified Data.ByteString.Char8 as S8 -import qualified Data.ByteString.Lazy as L -import Data.Monoid -import Control.Monad (void) - -withResponse :: Request - -> Manager - -> (Response BodyReader -> IO a) - -> IO a -withResponse req man f = bracket (responseOpen req man) responseClose f - -httpLbs :: Request -> Manager -> IO (Response L.ByteString) -httpLbs req man = withResponse req man $ \res -> do - bss <- brConsume $ responseBody res - return res { responseBody = L.fromChunks bss } - --- | Get a 'Response' without any redirect following. -httpRaw - :: Request - -> Manager - -> IO (Response BodyReader) -httpRaw req' m = do - (req, cookie_jar') <- case cookieJar req' of - Just cj -> do - now <- getCurrentTime - return $ insertCookiesIntoRequest req' (evictExpiredCookies cj now) now - Nothing -> return (req', mempty) - (timeout', (connRelease, ci, isManaged)) <- getConnectionWrapper - req - (responseTimeout' req) - (failedConnectionException req) - (getConn req m) - - -- Originally, we would only test for exceptions when sending the request, - -- not on calling @getResponse@. However, some servers seem to close - -- connections after accepting the request headers, so we need to check for - -- exceptions in both. - ex <- try $ do - requestBuilder req ci - - getResponse connRelease timeout' req ci - - case (ex, isManaged) of - -- Connection was reused, and might have been closed. Try again - (Left e, Reused) | mRetryableException m e -> do - connRelease DontReuse - responseOpen req m - -- Not reused, or a non-retry, so this is a real exception - (Left e, _) -> 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 res, _) -> case cookieJar req' of - Just _ -> do - now' <- getCurrentTime - let (cookie_jar, _) = updateCookieJar res req now' cookie_jar' - return $ res {responseCookieJar = cookie_jar} - Nothing -> return res - where - - responseTimeout' req - | rt == useDefaultTimeout = mResponseTimeout m - | otherwise = rt - where - rt = responseTimeout req - --- | The most low-level function for initiating an HTTP request. --- --- The first argument to this function gives a full specification --- on the request: the host to connect to, whether to use SSL, --- headers, etc. Please see 'Request' for full details. The --- second argument specifies which 'Manager' should be used. --- --- This function then returns a 'Response' with a --- 'C.Source'. The 'Response' contains the status code --- and headers that were sent back to us, and the --- 'C.Source' contains the body of the request. Note --- that this 'C.Source' allows you to have fully --- interleaved IO actions during your HTTP download, making it --- possible to download very large responses in constant memory. --- You may also directly connect the returned 'C.Source' --- into a 'C.Sink', perhaps a file or another socket. --- --- An important note: the response body returned by this function represents a --- live HTTP connection. As such, if you do not use the response body, an open --- socket will be retained until the containing @ResourceT@ block exits. If you --- do not need the response body, it is recommended that you explicitly shut --- down the connection immediately, using the pattern: --- --- > responseBody res $$+- return () --- --- As a more thorough example, consider the following program. Without the --- explicit response body closing, the program will run out of file descriptors --- around the 1000th request (depending on the operating system limits). --- --- > import Control.Monad (replicateM_) --- > import Control.Monad.IO.Class (liftIO) --- > import Data.Conduit (($$+-)) --- > import Network (withSocketsDo) --- > import Network.HTTP.Conduit --- > --- > main = withSocketsDo $ withManager $ \manager -> do --- > req <- parseUrl "http://localhost/" --- > mapM_ (worker manager req) [1..5000] --- > --- > worker manager req i = do --- > res <- http req manager --- > responseBody res $$+- return () -- The important line --- > liftIO $ print (i, responseStatus res) --- --- Note: Unlike previous versions, this function will perform redirects, as --- specified by the 'redirectCount' setting. -responseOpen :: Request -> Manager -> IO (Response BodyReader) -responseOpen req0 manager = mWrapIOException manager $ do - res <- - if redirectCount req0 == 0 - then httpRaw req0 manager - else go (redirectCount req0) req0 - maybe (return res) throwIO =<< applyCheckStatus (checkStatus req0) res - where - go count req' = httpRedirect - count - (\req -> do - res <- httpRaw req manager - let mreq = getRedirectedRequest req (responseHeaders res) (responseCookieJar res) (statusCode (responseStatus res)) - return (res, mreq)) - req' - --- | Apply 'Request'\'s 'checkStatus' and return resulting exception if any. -applyCheckStatus - :: (Status -> ResponseHeaders -> CookieJar -> Maybe SomeException) - -> Response BodyReader - -> IO (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 <- brReadSome (responseBody res) 1024 - return $ toException $ StatusCodeException s (hdrs ++ - [("X-Response-Body-Start", toStrict' lbs)]) cookie_jar - _ -> return exc - responseClose res - return (Just exc') - where -#if MIN_VERSION_bytestring(0,10,0) - toStrict' = L.toStrict -#else - toStrict' = S.concat . L.toChunks -#endif - --- | Redirect loop -httpRedirect - :: Int -- ^ 'redirectCount' - -> (Request -> IO (Response BodyReader, Maybe Request)) -- ^ function which performs a request and returns a response, and possibly another request if there's a redirect. - -> Request - -> IO (Response BodyReader) -httpRedirect count0 http' req0 = go count0 req0 [] - where - go (-1) _ ress = throwIO . TooManyRedirects =<< mapM lbsResponse ress - go count req' ress = do - (res, mreq) <- http' req' - case mreq of - Just req -> do - {- FIXME - -- Allow the original connection to return to the - -- connection pool immediately by flushing the body. - -- If the response body is too large, don't flush, but - -- instead just close the connection. - let maxFlush = 1024 - readMay bs = - case S8.readInt bs of - Just (i, bs') | S.null bs' -> Just i - _ -> Nothing - case lookup "content-length" (responseHeaders res) >>= readMay of - Just i | i > maxFlush -> return () - _ -> void $ brReadSome (responseBody res) maxFlush - -} - responseClose res - - -- And now perform the actual redirect - go (count - 1) req (res:ress) - Nothing -> return res diff --git a/src/Network/HTTP/Client/Body.hs b/src/Network/HTTP/Client/Body.hs deleted file mode 100644 --- a/src/Network/HTTP/Client/Body.hs +++ /dev/null @@ -1,194 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE OverloadedStrings #-} -module Network.HTTP.Client.Body where - -import Network.HTTP.Client.Connection -import Network.HTTP.Client.Types -import Control.Exception (throwIO, assert) -import Data.ByteString (ByteString, empty, uncons) -import Data.IORef -import qualified Data.ByteString as S -import qualified Data.ByteString.Lazy as L -import Control.Monad (unless, when) -import qualified Codec.Zlib as Z - -data BodyReader = BodyReader - { brRead :: !(IO ByteString) - , brComplete :: !(IO Bool) - } - -brReadSome :: BodyReader -> Int -> IO L.ByteString -brReadSome BodyReader {..} = - loop id - where - loop front rem - | rem <= 0 = return $ L.fromChunks $ front [] - | otherwise = do - bs <- brRead - if S.null bs - then return $ L.fromChunks $ front [] - else loop (front . (bs:)) (rem - S.length bs) - -brEmpty :: BodyReader -brEmpty = BodyReader - { brRead = return S.empty - , brComplete = return True - } - -brAddCleanup :: IO () -> BodyReader -> BodyReader -brAddCleanup cleanup br = BodyReader - { brRead = do - bs <- brRead br - when (S.null bs) cleanup - return bs - , brComplete = brComplete br - } - -brConsume :: BodyReader -> IO [S.ByteString] -brConsume f = - go id - where - go front = do - x <- brRead f - if S.null x - then return $ front [] - else go (front . (x:)) - -makeGzipReader :: BodyReader -> IO BodyReader -makeGzipReader br = do - inf <- Z.initInflate $ Z.WindowBits 31 - istate <- newIORef Nothing - let goPopper popper = do - mbs <- popper - case mbs of - Just bs -> do - writeIORef istate $ Just popper - return bs - Nothing -> do - bs <- Z.flushInflate inf - if S.null bs - then start - else do - writeIORef istate Nothing - return bs - start = do - bs <- brRead br - if S.null bs - then return S.empty - else do - popper <- Z.feedInflate inf bs - goPopper popper - return BodyReader - { brRead = do - state <- readIORef istate - case state of - Nothing -> start - Just popper -> goPopper popper - , brComplete = brComplete br - } - -makeUnlimitedReader :: Connection -> IO BodyReader -makeUnlimitedReader Connection {..} = do - icomplete <- newIORef False - return $! BodyReader - { brRead = do - bs <- connectionRead - when (S.null bs) $ writeIORef icomplete True - return bs - , brComplete = readIORef icomplete - } - -makeLengthReader :: Int -> Connection -> IO BodyReader -makeLengthReader count0 Connection {..} = do - icount <- newIORef count0 - return $! BodyReader - { brRead = do - count <- readIORef icount - if count <= 0 - then return empty - else do - bs <- connectionRead - when (S.null bs) $ throwIO $ ResponseBodyTooShort (fromIntegral count0) (fromIntegral $ count0 - count) - case compare count $ S.length bs of - LT -> do - let (x, y) = S.splitAt count bs - connectionUnread y - writeIORef icount (-1) - return x - EQ -> do - writeIORef icount (-1) - return bs - GT -> do - writeIORef icount (count - S.length bs) - return bs - , brComplete = fmap (== -1) $ readIORef icount - } - -makeChunkedReader :: Bool -- ^ send headers - -> Connection - -> IO BodyReader -makeChunkedReader sendHeaders conn@Connection {..} = do - icount <- newIORef 0 - return $! BodyReader - { brRead = go icount - , brComplete = do - count <- readIORef icount - return $! count == -1 - } - where - go icount = do - count0 <- readIORef icount - count <- - if count0 == 0 - then readHeader - else return count0 - if count <= 0 - then do - writeIORef icount (-1) - return empty - else do - (bs, count') <- sendChunk count - writeIORef icount count' - return bs - - sendChunk 0 = return (empty, 0) - sendChunk remainder = do - bs <- connectionRead - when (S.null bs) $ throwIO InvalidChunkHeaders - case compare remainder $ S.length bs of - LT -> do - let (x, y) = S.splitAt remainder bs - assert (not $ S.null y) $ connectionUnread y - requireNewline - return (x, 0) - EQ -> do - requireNewline - return (bs, 0) - GT -> return (bs, remainder - S.length bs) - - requireNewline = do - bs <- connectionReadLine conn - unless (S.null bs) $ throwIO InvalidChunkHeaders - - readHeader = do - bs <- connectionReadLine conn - case parseHex bs of - Nothing -> throwIO InvalidChunkHeaders - Just hex -> return hex - - parseHex bs0 = - case uncons bs0 of - Just (w0, bs') - | Just i0 <- toI w0 -> Just $ parseHex' i0 bs' - _ -> Nothing - parseHex' i bs = - case uncons bs of - Just (w, bs) - | Just i' <- toI w -> parseHex' (i * 16 + i') bs - _ -> i - - toI w - | 48 <= w && w <= 57 = Just $ fromIntegral w - 48 - | 65 <= w && w <= 70 = Just $ fromIntegral w - 55 - | 97 <= w && w <= 102 = Just $ fromIntegral w - 87 - | otherwise = Nothing diff --git a/src/Network/HTTP/Client/Connection.hs b/src/Network/HTTP/Client/Connection.hs deleted file mode 100644 --- a/src/Network/HTTP/Client/Connection.hs +++ /dev/null @@ -1,132 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} -module Network.HTTP.Client.Connection where - -import Data.ByteString (ByteString, empty) -import Data.IORef -import Control.Monad -import Control.Exception (throwIO) -import Network.HTTP.Client.Types -import Network.Socket (Socket, sClose, HostAddress, defaultHints, addrFlags) -import qualified Network.Socket as NS -import Network.Socket.ByteString (sendAll, recv) -import qualified Control.Exception as E -import qualified Data.ByteString as S -import Data.Word (Word8) - -connectionReadLine :: Connection -> IO ByteString -connectionReadLine conn = do - bs <- connectionRead conn - when (S.null bs) $ throwIO IncompleteHeaders - connectionReadLineWith conn bs - -connectionReadLineWith :: Connection -> ByteString -> IO ByteString -connectionReadLineWith conn bs0 = - go bs0 id 0 - where - go bs front total = - case S.breakByte charLF bs of - (_, "") -> do - let total' = total + S.length bs - when (total' > 1024) $ throwIO OverlongHeaders - bs' <- connectionRead conn - when (S.null bs') $ throwIO IncompleteHeaders - go bs' (front . (bs:)) total' - (x, S.drop 1 -> y) -> do - unless (S.null y) $! connectionUnread conn y - return $! killCR $! S.concat $! front [x] - -charLF, charCR, charSpace, charColon, charPeriod :: Word8 -charLF = 10 -charCR = 13 -charSpace = 32 -charColon = 58 -charPeriod = 46 - -killCR :: ByteString -> ByteString -killCR bs - | S.null bs = bs - | S.last bs == charCR = S.init bs - | otherwise = bs - - --- | For testing -dummyConnection :: [ByteString] -- ^ input - -> IO (Connection, IO [ByteString], IO [ByteString]) -- ^ conn, output, input -dummyConnection input0 = do - iinput <- newIORef input0 - ioutput <- newIORef [] - return (Connection - { connectionRead = atomicModifyIORef iinput $ \input -> - case input of - [] -> ([], empty) - x:xs -> (xs, x) - , connectionUnread = \x -> atomicModifyIORef iinput $ \input -> (x:input, ()) - , connectionWrite = \x -> atomicModifyIORef ioutput $ \output -> (output ++ [x], ()) - , connectionClose = return () - }, atomicModifyIORef ioutput $ \output -> ([], output), readIORef iinput) - -makeConnection :: IO ByteString -- ^ read - -> (ByteString -> IO ()) -- ^ write - -> IO () -- ^ close - -> IO Connection -makeConnection r w c = do - istack <- newIORef [] - _ <- mkWeakIORef istack c - return $! Connection - { connectionRead = join $ atomicModifyIORef istack $ \stack -> - case stack of - x:xs -> (xs, return x) - [] -> ([], r) - , connectionUnread = \x -> atomicModifyIORef istack $ \stack -> (x:stack, ()) - , connectionWrite = w - , connectionClose = c - } - -socketConnection :: Socket -> IO Connection -socketConnection socket = makeConnection - (recv socket 4096) - (sendAll socket) - (sClose socket) - -openSocketConnection :: Maybe HostAddress - -> String -- ^ host - -> Int -- ^ port - -> IO Connection -openSocketConnection hostAddress host port = do - let hints = NS.defaultHints { - NS.addrFlags = [NS.AI_ADDRCONFIG] - , NS.addrSocketType = NS.Stream - } - addrs <- case hostAddress of - Nothing -> - NS.getAddrInfo (Just hints) (Just host) (Just $ show port) - Just ha -> - return - [NS.AddrInfo - { NS.addrFlags = [] - , NS.addrFamily = NS.AF_INET - , NS.addrSocketType = NS.Stream - , NS.addrProtocol = 6 -- tcp - , NS.addrAddress = NS.SockAddrInet (toEnum port) ha - , NS.addrCanonName = Nothing - }] - - firstSuccessful addrs $ \addr -> - E.bracketOnError - (NS.socket (NS.addrFamily addr) (NS.addrSocketType addr) - (NS.addrProtocol addr)) - (NS.sClose) - (\sock -> do - NS.setSocketOption sock NS.NoDelay 1 - NS.connect sock (NS.addrAddress addr) - socketConnection sock) - -firstSuccessful :: [NS.AddrInfo] -> (NS.AddrInfo -> IO a) -> IO a -firstSuccessful [] _ = error "getAddrInfo returned empty list" -firstSuccessful (a:as) cb = - cb a `E.catch` \(e :: E.IOException) -> - case as of - [] -> E.throwIO e - _ -> firstSuccessful as cb diff --git a/src/Network/HTTP/Client/Cookies.hs b/src/Network/HTTP/Client/Cookies.hs deleted file mode 100644 --- a/src/Network/HTTP/Client/Cookies.hs +++ /dev/null @@ -1,246 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} --- | This module implements the algorithms described in RFC 6265 for the Network.HTTP.Conduit library. -module Network.HTTP.Client.Cookies where -{- - ( -- * Cookie functions - updateCookieJar - , receiveSetCookie - , generateCookie - , insertCheckedCookie - , insertCookiesIntoRequest - , computeCookieString - , evictExpiredCookies - ) where - -} - -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as S8 -import Data.Maybe -import qualified Data.List as L -import Data.Time.Clock -import Data.Time.Calendar -import Web.Cookie -import qualified Data.CaseInsensitive as CI -import Blaze.ByteString.Builder -import qualified Network.PublicSuffixList.Lookup as PSL -import Data.Text.Encoding (decodeUtf8With) -import Data.Text.Encoding.Error (lenientDecode) - -import qualified Network.HTTP.Client.Request as Req -import qualified Network.HTTP.Client.Response as Res -import Network.HTTP.Client.Types as Req - -slash :: Integral a => a -slash = 47 -- '/' - -isIpAddress :: BS.ByteString -> Bool -isIpAddress = - go 4 - where - go 0 bs = BS.null bs - go rest bs = - case S8.readInt x of - Just (i, x') | BS.null x' && i >= 0 && i < 256 -> go (rest - 1) y - _ -> False - where - (x, y') = BS.breakByte 46 bs -- period - y = BS.drop 1 y' - --- | This corresponds to the subcomponent algorithm entitled \"Domain Matching\" detailed --- in section 5.1.3 -domainMatches :: BS.ByteString -> BS.ByteString -> Bool -domainMatches string domainString - | string == domainString = True - | BS.length string < BS.length domainString + 1 = False - | domainString `BS.isSuffixOf` string && BS.singleton (BS.last difference) == "." && not (isIpAddress string) = True - | otherwise = False - where difference = BS.take (BS.length string - BS.length domainString) string - --- | This corresponds to the subcomponent algorithm entitled \"Paths\" detailed --- in section 5.1.4 -defaultPath :: Req.Request -> BS.ByteString -defaultPath req - | BS.null uri_path = "/" - | BS.singleton (BS.head uri_path) /= "/" = "/" - | BS.count slash uri_path <= 1 = "/" - | otherwise = BS.reverse $ BS.tail $ BS.dropWhile (/= slash) $ BS.reverse uri_path - where uri_path = Req.path req - --- | This corresponds to the subcomponent algorithm entitled \"Path-Match\" detailed --- 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) == "/" = True - | cookiePath `BS.isPrefixOf` path' && BS.singleton (BS.head remainder) == "/" = True - | otherwise = False - where remainder = BS.drop (BS.length cookiePath) requestPath - path' = case S8.uncons requestPath of - Just ('/', _) -> requestPath - _ -> '/' `S8.cons` requestPath - -createCookieJar :: [Cookie] -> CookieJar -createCookieJar = CJ - -destroyCookieJar :: CookieJar -> [Cookie] -destroyCookieJar = expose - -insertIntoCookieJar :: Cookie -> CookieJar -> CookieJar -insertIntoCookieJar cookie cookie_jar' = CJ $ cookie : cookie_jar - where cookie_jar = expose cookie_jar' - -removeExistingCookieFromCookieJar :: Cookie -> CookieJar -> (Maybe Cookie, CookieJar) -removeExistingCookieFromCookieJar cookie cookie_jar' = (mc, CJ lc) - where (mc, lc) = removeExistingCookieFromCookieJarHelper cookie (expose cookie_jar') - removeExistingCookieFromCookieJarHelper _ [] = (Nothing, []) - removeExistingCookieFromCookieJarHelper c (c' : cs) - | c == c' = (Just c', cs) - | otherwise = (cookie', c' : cookie_jar'') - where (cookie', cookie_jar'') = removeExistingCookieFromCookieJarHelper c cs - --- | Are we configured to reject cookies for domains such as \"com\"? -rejectPublicSuffixes :: Bool -rejectPublicSuffixes = True - -isPublicSuffix :: BS.ByteString -> Bool -isPublicSuffix = PSL.isSuffix . decodeUtf8With lenientDecode - --- | This corresponds to the eviction algorithm described in Section 5.3 \"Storage Model\" -evictExpiredCookies :: CookieJar -- ^ Input cookie jar - -> UTCTime -- ^ Value that should be used as \"now\" - -> CookieJar -- ^ Filtered cookie jar -evictExpiredCookies cookie_jar' now = CJ $ filter (\ cookie -> cookie_expiry_time cookie >= now) $ expose cookie_jar' - --- | This applies the 'computeCookieString' to a given Request -insertCookiesIntoRequest :: Req.Request -- ^ The request to insert into - -> CookieJar -- ^ Current cookie jar - -> UTCTime -- ^ Value that should be used as \"now\" - -> (Req.Request, CookieJar) -- ^ (Ouptut request, Updated cookie jar (last-access-time is updated)) -insertCookiesIntoRequest request cookie_jar now - | BS.null cookie_string = (request, cookie_jar') - | otherwise = (request {Req.requestHeaders = cookie_header : purgedHeaders}, cookie_jar') - where purgedHeaders = L.deleteBy (\ (a, _) (b, _) -> a == b) (CI.mk $ "Cookie", BS.empty) $ Req.requestHeaders request - (cookie_string, cookie_jar') = computeCookieString request cookie_jar now True - cookie_header = (CI.mk $ "Cookie", cookie_string) - --- | This corresponds to the algorithm described in Section 5.4 \"The Cookie Header\" -computeCookieString :: Req.Request -- ^ Input request - -> CookieJar -- ^ Current cookie jar - -> UTCTime -- ^ Value that should be used as \"now\" - -> Bool -- ^ Whether or not this request is coming from an \"http\" source (not javascript or anything like that) - -> (BS.ByteString, CookieJar) -- ^ (Contents of a \"Cookie\" header, Updated cookie jar (last-access-time is updated)) -computeCookieString request cookie_jar now is_http_api = (output_line, cookie_jar') - where matching_cookie cookie = condition1 && condition2 && condition3 && condition4 - where condition1 - | cookie_host_only cookie = Req.host request == cookie_domain cookie - | otherwise = domainMatches (Req.host request) (cookie_domain cookie) - condition2 = pathMatches (Req.path request) (cookie_path cookie) - condition3 - | not (cookie_secure_only cookie) = True - | otherwise = Req.secure request - condition4 - | not (cookie_http_only cookie) = True - | otherwise = is_http_api - matching_cookies = filter matching_cookie $ expose cookie_jar - output_cookies = map (\ c -> (cookie_name c, cookie_value c)) $ L.sort matching_cookies - output_line = toByteString $ renderCookies $ output_cookies - folding_function cookie_jar'' cookie = case removeExistingCookieFromCookieJar cookie cookie_jar'' of - (Just c, cookie_jar''') -> insertIntoCookieJar (c {cookie_last_access_time = now}) cookie_jar''' - (Nothing, cookie_jar''') -> cookie_jar''' - cookie_jar' = foldl folding_function cookie_jar matching_cookies - --- | This applies 'receiveSetCookie' to a given Response -updateCookieJar :: Res.Response a -- ^ Response received from server - -> Req.Request -- ^ Request which generated the response - -> UTCTime -- ^ Value that should be used as \"now\" - -> CookieJar -- ^ Current cookie jar - -> (CookieJar, Res.Response a) -- ^ (Updated cookie jar with cookies from the Response, The response stripped of any \"Set-Cookie\" header) -updateCookieJar response request now cookie_jar = (cookie_jar', response {Res.responseHeaders = other_headers}) - where (set_cookie_headers, other_headers) = L.partition ((== (CI.mk $ "Set-Cookie")) . fst) $ Res.responseHeaders response - set_cookie_data = map snd set_cookie_headers - set_cookies = map parseSetCookie set_cookie_data - cookie_jar' = foldl (\ cj sc -> receiveSetCookie sc request now True cj) cookie_jar set_cookies - --- | This corresponds to the algorithm described in Section 5.3 \"Storage Model\" --- This function consists of calling 'generateCookie' followed by 'insertCheckedCookie'. --- Use this function if you plan to do both in a row. --- 'generateCookie' and 'insertCheckedCookie' are only provided for more fine-grained control. -receiveSetCookie :: SetCookie -- ^ The 'SetCookie' the cookie jar is receiving - -> Req.Request -- ^ The request that originated the response that yielded the 'SetCookie' - -> UTCTime -- ^ Value that should be used as \"now\" - -> Bool -- ^ Whether or not this request is coming from an \"http\" source (not javascript or anything like that) - -> CookieJar -- ^ Input cookie jar to modify - -> CookieJar -- ^ Updated cookie jar -receiveSetCookie set_cookie request now is_http_api cookie_jar = case (do - cookie <- generateCookie set_cookie request now is_http_api - return $ insertCheckedCookie cookie cookie_jar is_http_api) of - Just cj -> cj - Nothing -> cookie_jar - --- | Insert a cookie created by generateCookie into the cookie jar (or not if it shouldn't be allowed in) -insertCheckedCookie :: Cookie -- ^ The 'SetCookie' the cookie jar is receiving - -> CookieJar -- ^ Input cookie jar to modify - -> Bool -- ^ Whether or not this request is coming from an \"http\" source (not javascript or anything like that) - -> CookieJar -- ^ Updated (or not) cookie jar -insertCheckedCookie c cookie_jar is_http_api = case (do - (cookie_jar', cookie') <- existanceTest c cookie_jar - return $ insertIntoCookieJar cookie' cookie_jar') of - Just cj -> cj - Nothing -> cookie_jar - where existanceTest cookie cookie_jar' = existanceTestHelper cookie $ removeExistingCookieFromCookieJar cookie cookie_jar' - existanceTestHelper new_cookie (Just old_cookie, cookie_jar') - | not is_http_api && cookie_http_only old_cookie = Nothing - | otherwise = return (cookie_jar', new_cookie {cookie_creation_time = cookie_creation_time old_cookie}) - existanceTestHelper new_cookie (Nothing, cookie_jar') = return (cookie_jar', new_cookie) - --- | Turn a SetCookie into a Cookie, if it is valid -generateCookie :: SetCookie -- ^ The 'SetCookie' we are encountering - -> Req.Request -- ^ The request that originated the response that yielded the 'SetCookie' - -> UTCTime -- ^ Value that should be used as \"now\" - -> Bool -- ^ Whether or not this request is coming from an \"http\" source (not javascript or anything like that) - -> Maybe Cookie -- ^ The optional output cookie -generateCookie set_cookie request now is_http_api = do - domain_sanitized <- sanitizeDomain $ step4 (setCookieDomain set_cookie) - domain_intermediate <- step5 domain_sanitized - (domain_final, host_only') <- step6 domain_intermediate - http_only' <- step10 - return $ Cookie { cookie_name = setCookieName set_cookie - , cookie_value = setCookieValue set_cookie - , cookie_expiry_time = getExpiryTime (setCookieExpires set_cookie) (setCookieMaxAge set_cookie) - , cookie_domain = domain_final - , cookie_path = getPath $ setCookiePath set_cookie - , cookie_creation_time = now - , cookie_last_access_time = now - , cookie_persistent = getPersistent - , cookie_host_only = host_only' - , cookie_secure_only = setCookieSecure set_cookie - , cookie_http_only = http_only' - } - where sanitizeDomain domain' - | has_a_character && BS.singleton (BS.last domain') == "." = Nothing - | has_a_character && BS.singleton (BS.head domain') == "." = Just $ BS.tail domain' - | otherwise = Just $ domain' - where has_a_character = not (BS.null domain') - step4 (Just set_cookie_domain) = set_cookie_domain - step4 Nothing = BS.empty - step5 domain' - | firstCondition && domain' == (Req.host request) = return BS.empty - | firstCondition = Nothing - | otherwise = return 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) - | otherwise = return (Req.host request, True) - where firstCondition = not $ BS.null domain' - step10 - | not is_http_api && setCookieHttpOnly set_cookie = Nothing - | otherwise = return $ setCookieHttpOnly set_cookie - getExpiryTime :: Maybe UTCTime -> Maybe DiffTime -> UTCTime - getExpiryTime _ (Just t) = (fromRational $ toRational t) `addUTCTime` now - getExpiryTime (Just t) Nothing = t - getExpiryTime Nothing Nothing = UTCTime (365000 `addDays` utctDay now) (secondsToDiffTime 0) - getPath (Just p) = p - getPath Nothing = defaultPath request - getPersistent = isJust (setCookieExpires set_cookie) || isJust (setCookieMaxAge set_cookie) diff --git a/src/Network/HTTP/Client/Headers.hs b/src/Network/HTTP/Client/Headers.hs deleted file mode 100644 --- a/src/Network/HTTP/Client/Headers.hs +++ /dev/null @@ -1,75 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ViewPatterns #-} -module Network.HTTP.Client.Headers where - -import Control.Applicative ((<$>), (<*>)) -import Control.Exception (throwIO) -import Control.Monad -import qualified Data.ByteString as S -import qualified Data.ByteString.Char8 as S8 -import qualified Data.CaseInsensitive as CI -import Network.HTTP.Client.Connection -import Network.HTTP.Client.Types -import Network.HTTP.Types - -parseStatusHeaders :: Connection -> IO StatusHeaders -parseStatusHeaders conn = do - (status, version) <- getStatusLine - headers <- parseHeaders 0 id - return $! StatusHeaders status version headers - where - getStatusLine = do - -- Ensure that there is some data coming in. If not, we want to signal - -- this as a connection problem and not a protocol problem. - bs <- connectionRead conn - when (S.null bs) $ throwIO NoResponseDataReceived - - status@(code, _) <- connectionReadLineWith conn bs >>= parseStatus 3 - if code == status100 - then newline ExpectedBlankAfter100Continue >> getStatusLine - else return status - - newline exc = do - line <- connectionReadLine conn - unless (S.null line) $ throwIO exc - - parseStatus :: Int -> S.ByteString -> IO (Status, HttpVersion) - parseStatus i bs | S.null bs && i > 0 = connectionReadLine conn >>= parseStatus (i - 1) - 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 <*> readInt code of - Just (ver', code') -> return (Status code' msg, ver') - Nothing -> throwIO $ InvalidStatusLine bs - - stripPrefixBS x y - | x `S.isPrefixOf` y = Just $ S.drop (S.length x) y - | otherwise = Nothing - parseVersion bs0 = do - bs1 <- stripPrefixBS "HTTP/" bs0 - let (num1, S.drop 1 -> num2) = S.breakByte charPeriod bs1 - HttpVersion <$> readInt num1 <*> readInt num2 - - readInt bs = - case S8.readInt bs of - Just (i, "") -> Just i - _ -> Nothing - - parseHeaders 100 _ = throwIO OverlongHeaders - parseHeaders count front = do - line <- connectionReadLine conn - if S.null line - then return $ front [] - else do - header <- parseHeader line - parseHeaders (count + 1) $ front . (header:) - - parseHeader :: S.ByteString -> IO Header - parseHeader bs = do - let (key, bs2) = S.breakByte charColon bs - when (S.null bs2) $ throwIO $ InvalidHeader bs - return (CI.mk $! strip key, strip $! S.drop 1 bs2) - - strip = S.dropWhile (== charSpace) . fst . S.spanEnd (== charSpace) diff --git a/src/Network/HTTP/Client/Manager.hs b/src/Network/HTTP/Client/Manager.hs deleted file mode 100644 --- a/src/Network/HTTP/Client/Manager.hs +++ /dev/null @@ -1,371 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE RankNTypes #-} -module Network.HTTP.Client.Manager - ( Manager - , mResponseTimeout - , mRetryableException - , mWrapIOException - , ManagerSettings (..) - , ConnKey (..) - , ConnHost (..) - , newManager - , closeManager - , getConn - , ConnReuse (..) - , ConnRelease - , ManagedConn (..) - , failedConnectionException - , defaultManagerSettings - ) where - -#if !MIN_VERSION_base(4,6,0) -import Prelude hiding (catch) -#endif -import Data.Monoid (mappend) -import System.IO (hClose, hFlush, IOMode(..)) -import qualified Data.IORef as I -import qualified Data.Map as Map - -import qualified Data.ByteString.Char8 as S8 -import qualified Data.ByteString.Lazy as L - -import qualified Blaze.ByteString.Builder as Blaze - -import Data.Text (Text) -import qualified Data.Text as T - -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Exception (mask_, SomeException, catch, throwIO, fromException, mask, IOException, Exception (..), handle) -import Control.Concurrent (forkIO, threadDelay) -import Data.Time (UTCTime (..), Day (..), DiffTime, getCurrentTime, addUTCTime) -import Control.DeepSeq (deepseq) - -import qualified Network.Socket as NS - -import Data.Default -import Data.Maybe (mapMaybe) -import System.IO (Handle) -import System.Mem.Weak (Weak, deRefWeak) -import Network.HTTP.Client.Types -import Network.HTTP.Client.Connection - --- | Settings for a @Manager@. Please use the 'defaultManagerSettings' function and then modify --- individual settings. -data ManagerSettings = ManagerSettings - { managerConnCount :: !Int - -- ^ Number of connections to a single host to keep alive. Default: 10. - , managerRawConnection :: !(IO (Maybe NS.HostAddress -> String -> Int -> IO Connection)) - -- ^ Create an insecure connection. - , managerTlsConnection :: !(IO (Maybe NS.HostAddress -> String -> Int -> IO Connection)) - -- ^ Create a TLS connection. Default behavior: throw an exception that TLS is not supported. - , managerResponseTimeout :: !(Maybe Int) - -- ^ Default timeout (in microseconds) to be applied to requests which do - -- not provide a timeout value. - -- - -- Default is 5 seconds - -- - -- Since 1.9.3 - , managerRetryableException :: !(SomeException -> Bool) - -- ^ Exceptions for which we should retry our request if we were reusing an - -- already open connection. In the case of IOExceptions, for example, we - -- assume that the connection was closed on the server and therefore open a - -- new one. - , managerWrapIOException :: !(forall a. IO a -> IO a) - } - -defaultManagerSettings :: ManagerSettings -defaultManagerSettings = ManagerSettings - { managerConnCount = 10 - , managerRawConnection = return openSocketConnection - , managerTlsConnection = return $ \_ _ _ -> throwIO TlsNotSupported - , managerResponseTimeout = Just 5000000 - , managerRetryableException = \e -> - case fromException e of - Just (_ :: IOException) -> True - _ -> - case fromException e of - -- Note: Some servers will timeout connections by accepting - -- the incoming packets for the new request, but closing - -- the connection as soon as we try to read. To make sure - -- we open a new connection under these circumstances, we - -- check for the NoResponseDataReceived exception. - Just NoResponseDataReceived -> True - _ -> False - , managerWrapIOException = - let wrapper se = - case fromException se of - Just e -> toException $ InternalIOException e - Nothing -> se - in handle $ throwIO . wrapper - } - --- | Keeps track of open connections for keep-alive. --- If possible, you should share a single 'Manager' between multiple threads and requests. -data Manager = Manager - { mConns :: !(I.IORef (Maybe (Map.Map ConnKey (NonEmptyList Connection)))) - -- ^ @Nothing@ indicates that the manager is closed. - , mMaxConns :: !Int - -- ^ This is a per-@ConnKey@ value. - , mResponseTimeout :: !(Maybe Int) - -- ^ Copied from 'managerResponseTimeout' - , mRawConnection :: !(Maybe NS.HostAddress -> String -> Int -> IO Connection) - , mTlsConnection :: !(Maybe NS.HostAddress -> String -> Int -> IO Connection) - , mRetryableException :: !(SomeException -> Bool) - , mWrapIOException :: !(forall a. IO a -> IO a) - } - -data NonEmptyList a = - One !a !UTCTime | - Cons !a !Int !UTCTime !(NonEmptyList a) - --- | Hostname or resolved host address. -data ConnHost = - HostName !Text | - HostAddress !NS.HostAddress - deriving (Eq, Show, Ord) - --- | @ConnKey@ consists of a hostname, a port and a @Bool@ --- specifying whether to use SSL. -data ConnKey = ConnKey !ConnHost !Int !Bool - deriving (Eq, Show, Ord) - -takeSocket :: Manager -> ConnKey -> IO (Maybe Connection) -takeSocket man key = - I.atomicModifyIORef (mConns man) go - where - go Nothing = (Nothing, Nothing) - go (Just m) = - case Map.lookup key m of - Nothing -> (Just m, Nothing) - Just (One a _) -> (Just $ Map.delete key m, Just a) - Just (Cons a _ _ rest) -> (Just $ Map.insert key rest m, Just a) - -putSocket :: Manager -> ConnKey -> Connection -> IO () -putSocket man key ci = do - now <- getCurrentTime - msock <- I.atomicModifyIORef (mConns man) (go now) - maybe (return ()) connectionClose msock - where - go _ Nothing = (Nothing, Just ci) - go now (Just m) = - case Map.lookup key m of - Nothing -> (Just $ Map.insert key (One ci now) m, Nothing) - Just l -> - let (l', mx) = addToList now (mMaxConns man) ci l - in (Just $ Map.insert key l' m, mx) - --- | Add a new element to the list, up to the given maximum number. If we're --- already at the maximum, return the new value as leftover. -addToList :: UTCTime -> Int -> a -> NonEmptyList a -> (NonEmptyList a, Maybe a) -addToList _ i x l | i <= 1 = (l, Just x) -addToList now _ x l@One{} = (Cons x 2 now l, Nothing) -addToList now maxCount x l@(Cons _ currCount _ _) - | maxCount > currCount = (Cons x (currCount + 1) now l, Nothing) - | otherwise = (l, Just x) - --- | Create a 'Manager'. You must manually call 'closeManager' to shut it down. --- --- Creating a new 'Manager' is an expensive operation, you are advised to share --- a single 'Manager' between requests instead. -newManager :: ManagerSettings -> IO Manager -newManager ms = do - rawConnection <- managerRawConnection ms - tlsConnection <- managerTlsConnection ms - mapRef <- I.newIORef (Just Map.empty) - wmapRef <- I.mkWeakIORef mapRef $ closeManager' mapRef - _ <- forkIO $ reap wmapRef - let manager = Manager - { mConns = mapRef - , mMaxConns = managerConnCount ms - , mResponseTimeout = managerResponseTimeout ms - , mRawConnection = rawConnection - , mTlsConnection = tlsConnection - , mRetryableException = managerRetryableException ms - , mWrapIOException = managerWrapIOException ms - } - return manager - --- | Collect and destroy any stale connections. -reap :: Weak (I.IORef (Maybe (Map.Map ConnKey (NonEmptyList Connection)))) - -> IO () -reap wmapRef = - mask_ loop - where - loop = do - threadDelay (5 * 1000 * 1000) - mmapRef <- deRefWeak wmapRef - case mmapRef of - Nothing -> return () -- manager is closed - Just mapRef -> goMapRef mapRef - - goMapRef mapRef = do - now <- getCurrentTime - let isNotStale time = 30 `addUTCTime` time >= now - mtoDestroy <- I.atomicModifyIORef mapRef (findStaleWrap isNotStale) - case mtoDestroy of - Nothing -> return () -- manager is closed - Just toDestroy -> do - mapM_ safeConnClose toDestroy - loop - findStaleWrap _ Nothing = (Nothing, Nothing) - findStaleWrap isNotStale (Just m) = - let (x, y) = findStale isNotStale m - in (Just x, Just y) - findStale isNotStale = - findStale' id id . Map.toList - where - findStale' destroy keep [] = (Map.fromList $ keep [], destroy []) - findStale' destroy keep ((connkey, nelist):rest) = - findStale' destroy' keep' rest - where - -- Note: By definition, the timestamps must be in descending order, - -- so we don't need to traverse the whole list. - (notStale, stale) = span (isNotStale . fst) $ neToList nelist - destroy' = destroy . (map snd stale++) - keep' = - case neFromList notStale of - Nothing -> keep - Just x -> keep . ((connkey, x):) - - flushStaleCerts now = - Map.fromList . mapMaybe flushStaleCerts' . Map.toList - where - flushStaleCerts' (host', inner) = - case mapMaybe flushStaleCerts'' $ Map.toList inner of - [] -> Nothing - pairs -> - let x = take 10 pairs - in x `seqPairs` Just (host', Map.fromList x) - flushStaleCerts'' (certs, expires) - | expires > now = Just (certs, expires) - | otherwise = Nothing - - seqPairs :: [(L.ByteString, UTCTime)] -> b -> b - seqPairs [] b = b - seqPairs (p:ps) b = p `seqPair` ps `seqPairs` b - - seqPair :: (L.ByteString, UTCTime) -> b -> b - seqPair (lbs, utc) b = lbs `seqLBS` utc `seqUTC` b - - seqLBS :: L.ByteString -> b -> b - seqLBS lbs b = L.length lbs `seq` b - - seqUTC :: UTCTime -> b -> b - seqUTC (UTCTime day dt) b = day `seqDay` dt `seqDT` b - - seqDay :: Day -> b -> b - seqDay (ModifiedJulianDay i) b = i `deepseq` b - - seqDT :: DiffTime -> b -> b - seqDT = seq - -neToList :: NonEmptyList a -> [(UTCTime, a)] -neToList (One a t) = [(t, a)] -neToList (Cons a _ t nelist) = (t, a) : neToList nelist - -neFromList :: [(UTCTime, a)] -> Maybe (NonEmptyList a) -neFromList [] = Nothing -neFromList [(t, a)] = Just (One a t) -neFromList xs = - Just . snd . go $ xs - where - go [] = error "neFromList.go []" - go [(t, a)] = (2, One a t) - go ((t, a):rest) = - let (i, rest') = go rest - i' = i + 1 - in i' `seq` (i', Cons a i t rest') - --- | Close all connections in a 'Manager'. Afterwards, the 'Manager' --- can be reused if desired. --- --- Note that this doesn't affect currently in-flight connections, --- meaning you can safely use it without hurting any queries you may --- have concurrently running. -closeManager :: Manager -> IO () -closeManager = closeManager' . mConns - -closeManager' :: I.IORef (Maybe (Map.Map ConnKey (NonEmptyList Connection))) - -> IO () -closeManager' connsRef = mask_ $ do - m <- I.atomicModifyIORef connsRef $ \x -> (Nothing, x) - mapM_ (nonEmptyMapM_ safeConnClose) $ maybe [] Map.elems m - -safeConnClose :: Connection -> IO () -safeConnClose ci = connectionClose ci `catch` \(_::SomeException) -> return () - -nonEmptyMapM_ :: Monad m => (a -> m ()) -> NonEmptyList a -> m () -nonEmptyMapM_ f (One x _) = f x -nonEmptyMapM_ f (Cons x _ _ l) = f x >> nonEmptyMapM_ f l - --- | 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 --- either released or returned to the manager. -getManagedConn - :: Manager - -> ConnKey - -> IO Connection - -> IO (ConnRelease, Connection, ManagedConn) --- We want to avoid any holes caused by async exceptions, so let's mask. -getManagedConn man key open = mask $ \restore -> do - -- Try to take the socket out of the manager. - mci <- takeSocket man key - (ci, isManaged) <- - case mci of - -- There wasn't a matching connection in the manager, so create a - -- new one. - Nothing -> do - ci <- restore open - return (ci, Fresh) - -- Return the existing one - Just ci -> return (ci, Reused) - - -- When we release this connection, we can either reuse it (put it back in - -- the manager) or not reuse it (close the socket). We set up a mutable - -- reference to track what we want to do. By default, we say not to reuse - -- it, that way if an exception is thrown, the connection won't be reused. - toReuseRef <- I.newIORef DontReuse - - -- When the connection is explicitly released, we update our toReuseRef to - -- indicate what action should be taken, and then call release. - let connRelease Reuse = putSocket man key ci - connRelease DontReuse = connectionClose ci - - return (connRelease, ci, isManaged) - --- | Create an exception to be thrown if the connection for the given request --- fails. -failedConnectionException :: Request -> HttpException -failedConnectionException req = - FailedConnectionException host' port' - where - (_, host', port') = getConnDest req - -getConnDest :: Request -> (Bool, String, Int) -getConnDest req = - case proxy req of - Just p -> (True, S8.unpack (proxyHost p), proxyPort p) - Nothing -> (False, S8.unpack $ host req, port req) - -getConn :: Request - -> Manager - -> IO (ConnRelease, Connection, ManagedConn) -getConn req m = - getManagedConn m (ConnKey connKeyHost connport (secure req)) $ - go connaddr connhost connport - where - h = host req - (useProxy, connhost, connport) = getConnDest req - (connaddr, connKeyHost) = - case (hostAddress req, useProxy{-, socksProxy req-}) of - (Just ha, False{-, Nothing-}) -> (Just ha, HostAddress ha) - _ -> (Nothing, HostName $ T.pack connhost) - go = - case (secure req, useProxy) of - (False, _) -> mRawConnection m - (True, False) -> mTlsConnection m - -- FIXME (True, True) -> getSslProxyConn (checkCerts m h) (clientCertificates req) h (port req) diff --git a/src/Network/HTTP/Client/Request.hs b/src/Network/HTTP/Client/Request.hs deleted file mode 100644 --- a/src/Network/HTTP/Client/Request.hs +++ /dev/null @@ -1,343 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE CPP #-} - -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Network.HTTP.Client.Request - ( parseUrl - , setUriRelative - , getUri - , setUri - , browserDecompress - , alwaysDecompress - , addProxy - , applyBasicAuth - , urlEncodedBody - , needsGunzip - , requestBuilder - , useDefaultTimeout - ) where - -import Data.Maybe (fromMaybe, isJust) -import Data.Monoid (mempty, mappend) -import Data.String (IsString(..)) -import Control.Monad (when, unless) -import Numeric (showHex) - -import Data.Default (Default (def)) - -import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString, toByteStringIO) -import Blaze.ByteString.Builder.Char8 (fromChar) - -import qualified Data.ByteString as S -import qualified Data.ByteString.Char8 as S8 -import qualified Data.ByteString.Lazy as L - -import qualified Network.HTTP.Types as W -import Network.URI (URI (..), URIAuth (..), parseURI, relativeTo, escapeURIString, isAllowedInURI) - -import Control.Monad.IO.Class (liftIO) -import Control.Exception (Exception, toException, throw, throwIO) -import Control.Failure (Failure (failure)) -import qualified Data.CaseInsensitive as CI -import qualified Data.ByteString.Base64 as B64 - -import Network.HTTP.Client.Types -import Network.HTTP.Client.Connection - -import Network.HTTP.Client.Util (readDec, (<>)) -import System.Timeout (timeout) -import Data.Time.Clock - --- | Convert a URL into a 'Request'. --- --- This defaults some of the values in 'Request', such as setting 'method' to --- GET and 'requestHeaders' to @[]@. --- --- Since this function uses 'Failure', the return monad can be anything that is --- an instance of 'Failure', such as 'IO' or 'Maybe'. -parseUrl :: Failure HttpException m => String -> m Request -parseUrl s = - case parseURI (encode s) of - Just uri -> setUri def uri - Nothing -> failure $ InvalidUrlException s "Invalid URL" - where - encode = escapeURIString isAllowedInURI - --- | Add a 'URI' to the request. If it is absolute (includes a host name), add --- it as per 'setUri'; if it is relative, merge it with the existing request. -setUriRelative :: Failure HttpException m => Request -> URI -> m Request -setUriRelative req uri = -#if MIN_VERSION_network(2,4,0) - setUri req $ uri `relativeTo` getUri req -#else - case uri `relativeTo` getUri req of - Just uri' -> setUri req uri' - Nothing -> failure $ InvalidUrlException (show uri) "Invalid URL" -#endif - --- | Extract a 'URI' from the request. -getUri :: Request -> URI -getUri req = URI - { uriScheme = if secure req - then "https:" - else "http:" - , uriAuthority = Just URIAuth - { uriUserInfo = "" - , uriRegName = S8.unpack $ host req - , uriPort = ':' : show (port req) - } - , uriPath = S8.unpack $ path req - , uriQuery = S8.unpack $ queryString req - , uriFragment = "" - } - --- | Validate a 'URI', then add it to the request. -setUri :: Failure HttpException m => Request -> URI -> m Request -setUri req uri = do - sec <- parseScheme uri - auth <- maybe (failUri "URL must be absolute") return $ uriAuthority uri - if not . null $ uriUserInfo auth - then failUri "URL auth not supported; use applyBasicAuth instead" - else return () - port' <- parsePort sec auth - return req - { host = S8.pack $ uriRegName auth - , port = port' - , secure = sec - , path = S8.pack $ - if null $ uriPath uri - then "/" - else uriPath uri - , queryString = S8.pack $ uriQuery uri - } - where - failUri :: Failure HttpException m => String -> m a - failUri = failure . InvalidUrlException (show uri) - - parseScheme URI{uriScheme = scheme} = - case scheme of - "http:" -> return False - "https:" -> return True - _ -> failUri "Invalid scheme" - - parsePort sec URIAuth{uriPort = portStr} = - case portStr of - -- If the user specifies a port, then use it - ':':rest -> maybe - (failUri "Invalid port") - return - (readDec rest) - -- Otherwise, use the default port - _ -> case sec of - False {- HTTP -} -> return 80 - True {- HTTPS -} -> return 443 - -instance Show Request where - show x = unlines - [ "Request {" - , " host = " ++ show (host x) - , " port = " ++ show (port x) - , " secure = " ++ show (secure x) - , " requestHeaders = " ++ show (requestHeaders x) - , " path = " ++ show (path x) - , " queryString = " ++ show (queryString x) - --, " requestBody = " ++ show (requestBody x) - , " method = " ++ show (method x) - , " proxy = " ++ show (proxy x) - , " rawBody = " ++ show (rawBody x) - , " redirectCount = " ++ show (redirectCount x) - , " responseTimeout = " ++ show (responseTimeout x) - , "}" - ] - --- | Magic value to be placed in a 'Request' to indicate that we should use the --- timeout value in the @Manager@. --- --- Since 1.9.3 -useDefaultTimeout :: Maybe Int -useDefaultTimeout = Just (-3425) - -instance Default Request where - def = Request - { host = "localhost" - , port = 80 - , secure = False - , requestHeaders = [] - , path = "/" - , queryString = S8.empty - , requestBody = RequestBodyLBS L.empty - , method = "GET" - , proxy = Nothing - , hostAddress = Nothing - , rawBody = False - , decompress = browserDecompress - , redirectCount = 10 - , checkStatus = \s@(W.Status sci _) hs cookie_jar -> - if 200 <= sci && sci < 300 - then Nothing - else Just $ toException $ StatusCodeException s hs cookie_jar - , responseTimeout = useDefaultTimeout - , getConnectionWrapper = \mtimeout exc f -> - case mtimeout of - Nothing -> fmap ((,) Nothing) f - Just timeout' -> do - before <- getCurrentTime - mres <- timeout timeout' f - case mres of - Nothing -> throwIO exc - Just res -> do - now <- getCurrentTime - let timeSpentMicro = diffUTCTime now before * 1000000 - remainingTime = round $ fromIntegral timeout' - timeSpentMicro - if remainingTime <= 0 - then throwIO exc - else return (Just remainingTime, res) - , cookieJar = Just def - } - -instance IsString Request where - fromString s = - case parseUrl s of - Left e -> throw (e :: HttpException) - Right r -> r - --- | Always decompress a compressed stream. -alwaysDecompress :: ContentType -> Bool -alwaysDecompress = const True - --- | Decompress a compressed stream unless the content-type is 'application/x-tar'. -browserDecompress :: ContentType -> Bool -browserDecompress = (/= "application/x-tar") - --- | Add a Basic Auth header (with the specified user name and password) to the --- given Request. Ignore error handling: --- --- applyBasicAuth "user" "pass" $ fromJust $ parseUrl url - -applyBasicAuth :: S.ByteString -> S.ByteString -> Request -> Request -applyBasicAuth user passwd req = - req { requestHeaders = authHeader : requestHeaders req } - where - authHeader = (CI.mk "Authorization", basic) - basic = S8.append "Basic " (B64.encode $ S8.concat [ user, ":", passwd ]) - - --- | Add a proxy to the Request so that the Request when executed will use --- the provided proxy. -addProxy :: S.ByteString -> Int -> Request -> Request -addProxy hst prt req = - req { proxy = Just $ Proxy hst prt } - --- | Add url-encoded parameters to the 'Request'. --- --- This sets a new 'requestBody', adds a content-type request header and --- changes the 'method' to POST. -urlEncodedBody :: [(S.ByteString, S.ByteString)] -> Request -> Request -urlEncodedBody headers req = req - { requestBody = RequestBodyLBS body - , method = "POST" - , requestHeaders = - (ct, "application/x-www-form-urlencoded") - : filter (\(x, _) -> x /= ct) (requestHeaders req) - } - where - ct = "Content-Type" - body = L.fromChunks . return $ W.renderSimpleQuery False headers - -needsGunzip :: Request - -> [W.Header] -- ^ response headers - -> Bool -needsGunzip req hs' = - not (rawBody req) - && ("content-encoding", "gzip") `elem` hs' - && decompress req (fromMaybe "" $ lookup "content-type" hs') - -requestBuilder :: Request -> Connection -> IO () -requestBuilder req Connection {..} = - bodySource - where - writeBuilder = toByteStringIO connectionWrite - - (contentLength, bodySource) = - case requestBody req of - RequestBodyLBS lbs -> (Just $ L.length lbs, writeBuilder $ builder `mappend` fromLazyByteString lbs) - RequestBodyBS bs -> (Just $ fromIntegral $ S.length bs, writeBuilder $ builder `mappend` fromByteString bs) - RequestBodyBuilder i b -> (Just $ i, writeBuilder $ builder `mappend` b) - RequestBodyStream i stream -> (Just i, writeBuilder builder >> writeStream False stream) - RequestBodyStreamChunked stream -> (Nothing, writeBuilder builder >> writeStream True stream) - - writeStream isChunked withStream = - withStream loop - where - loop stream = do - bs <- stream - when isChunked $ - connectionWrite $ S8.pack $ showHex (S.length bs) "\r\n" - unless (S.null bs) $ do - connectionWrite bs - when isChunked $ connectionWrite "\r\n" - loop stream - - - hh - | port req == 80 && not (secure req) = host req - | port req == 443 && secure req = host req - | otherwise = host req <> S8.pack (':' : show (port req)) - - requestProtocol - | secure req = fromByteString "https://" - | otherwise = fromByteString "http://" - - requestHostname - | isJust (proxy req) = requestProtocol <> fromByteString hh - | otherwise = mempty - - contentLengthHeader (Just contentLength') = - if method req `elem` ["GET", "HEAD"] && contentLength' == 0 - then id - else (:) ("Content-Length", S8.pack $ show contentLength') - contentLengthHeader Nothing = (:) ("Transfer-Encoding", "chunked") - - acceptEncodingHeader = - case lookup "Accept-Encoding" $ requestHeaders req of - Nothing -> (("Accept-Encoding", "gzip"):) - Just "" -> filter (\(k, _) -> k /= "Accept-Encoding") - Just _ -> id - - hostHeader x = - case lookup "Host" x of - Nothing -> ("Host", hh) : x - Just{} -> x - - headerPairs :: W.RequestHeaders - headerPairs = hostHeader - $ acceptEncodingHeader - $ contentLengthHeader contentLength - $ requestHeaders req - - builder :: Builder - builder = - fromByteString (method req) - <> fromByteString " " - <> requestHostname - <> (case S8.uncons $ path req of - Just ('/', _) -> fromByteString $ path req - _ -> fromChar '/' <> fromByteString (path req)) - <> (case S8.uncons $ queryString req of - Nothing -> mempty - Just ('?', _) -> fromByteString $ queryString req - _ -> fromChar '?' <> fromByteString (queryString req)) - <> fromByteString " HTTP/1.1\r\n" - <> foldr - (\a b -> headerPairToBuilder a <> b) - (fromByteString "\r\n") - headerPairs - - headerPairToBuilder (k, v) = - fromByteString (CI.original k) - <> fromByteString ": " - <> fromByteString v - <> fromByteString "\r\n" diff --git a/src/Network/HTTP/Client/Response.hs b/src/Network/HTTP/Client/Response.hs deleted file mode 100644 --- a/src/Network/HTTP/Client/Response.hs +++ /dev/null @@ -1,140 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE CPP #-} -module Network.HTTP.Client.Response - ( Response (..) - , getRedirectedRequest - , getResponse - , lbsResponse - ) where - -import Control.Arrow (first) -import Control.Monad (liftM) - -import Control.Exception (throwIO) -import Control.Monad.IO.Class (MonadIO, liftIO) - -import qualified Data.ByteString as S -import qualified Data.ByteString.Char8 as S8 -import qualified Data.ByteString.Lazy as L - -import qualified Data.CaseInsensitive as CI - -import Data.Default (def) - -import qualified Network.HTTP.Types as W -import Network.URI (parseURIReference) - -import Network.HTTP.Client.Types - -import Network.HTTP.Client.Manager -import Network.HTTP.Client.Request -import Network.HTTP.Client.Util -import Network.HTTP.Client.Body -import Network.HTTP.Client.Headers -import Network.HTTP.Client.Connection - -import System.Timeout (timeout) - --- | If a request is a redirection (status code 3xx) this function will create --- a new request from the old request, the server headers returned with the --- redirection, and the redirection code itself. This function returns 'Nothing' --- if the code is not a 3xx, there is no 'location' header included, or if the --- redirected response couldn't be parsed with 'parseUrl'. --- --- If a user of this library wants to know the url chain that results from a --- specific request, that user has to re-implement the redirect-following logic --- themselves. An example of that might look like this: --- --- > 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 -> W.ResponseHeaders -> CookieJar -> Int -> Maybe Request -getRedirectedRequest req hs cookie_jar code - | 300 <= code && code < 400 = do - l' <- lookup "location" hs - req' <- setUriRelative req =<< parseURIReference (S8.unpack l') - return $ - if code == 302 || code == 303 - -- According to the spec, this should *only* be for status code - -- 303. However, almost all clients mistakenly implement it for - -- 302 as well. So we have to be wrong like everyone else... - then req' - { method = "GET" - , requestBody = RequestBodyBS "" - , cookieJar = cookie_jar' - } - 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. -lbsResponse :: Response BodyReader -> IO (Response L.ByteString) -lbsResponse res = do - bss <- brConsume $ responseBody res - return res - { responseBody = L.fromChunks bss - } - -getResponse :: ConnRelease - -> Maybe Int - -> Request - -> Connection - -> IO (Response BodyReader) -getResponse connRelease timeout'' req@(Request {..}) conn = do - let timeout' = - case timeout'' of - Nothing -> id - Just useconds -> \ma -> do - x <- timeout useconds ma - case x of - Nothing -> liftIO $ throwIO ResponseTimeout - Just y -> return y - StatusHeaders s version hs <- timeout' $ parseStatusHeaders conn - let mcl = lookup "content-length" hs >>= readDec . S8.unpack - - -- should we put this connection back into the connection manager? - toPut = Just "close" /= lookup "connection" hs && version > W.HttpVersion 1 0 - cleanup bodyConsumed = connRelease $ if toPut && bodyConsumed then Reuse else DontReuse - - body <- - -- RFC 2616 section 4.4_1 defines responses that must not include a body - if hasNoBody method (W.statusCode s) || mcl == Just 0 - then do - cleanup True - return brEmpty - else do - let isChunked = ("transfer-encoding", "chunked") `elem` hs - body1 <- - if isChunked - then makeChunkedReader rawBody conn - else - case mcl of - Just len -> makeLengthReader len conn - Nothing -> makeUnlimitedReader conn - body2 <- if needsGunzip req hs - then makeGzipReader body1 - else return body1 - return $ brAddCleanup (cleanup True) body2 - - return Response - { responseStatus = s - , responseVersion = version - , responseHeaders = hs - , responseBody = body - , responseCookieJar = def - , responseClose' = ResponseClose (cleanup False) - } diff --git a/src/Network/HTTP/Client/Types.hs b/src/Network/HTTP/Client/Types.hs deleted file mode 100644 --- a/src/Network/HTTP/Client/Types.hs +++ /dev/null @@ -1,327 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFunctor #-} -module Network.HTTP.Client.Types where - -import Data.Typeable -import Network.HTTP.Types -import Control.Exception (Exception, IOException, SomeException) -import Data.Word (Word64) -import qualified Data.ByteString as S -import qualified Data.ByteString.Lazy as L -import Blaze.ByteString.Builder (Builder, fromLazyByteString, fromByteString, toLazyByteString) -import Data.Int (Int64) -import Data.Default -import Data.Monoid -import Data.Time (UTCTime) -import qualified Data.List as DL -import Network.Socket (HostAddress) -import Data.IORef - -data Connection = Connection - { connectionRead :: !(IO S.ByteString) - -- ^ If no more data, return empty. - , connectionUnread :: !(S.ByteString -> IO ()) - -- ^ Return data to be read next time. - , connectionWrite :: !(S.ByteString -> IO ()) - -- ^ Send data to server - , connectionClose :: !(IO ()) - } - -data StatusHeaders = StatusHeaders !Status !HttpVersion !RequestHeaders - deriving (Show, Eq, Ord) - -data HttpException = StatusCodeException Status 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. - | TooManyRetries - | HttpParserException String - | HandshakeFailed - | OverlongHeaders - | ResponseTimeout - | FailedConnectionException String Int -- ^ host/port - | ExpectedBlankAfter100Continue - | InvalidStatusLine S.ByteString - | InvalidHeader S.ByteString - | InternalIOException IOException - | ProxyConnectException S.ByteString Int (Either S.ByteString HttpException) -- ^ host/port - | NoResponseDataReceived - | TlsException SomeException - | TlsNotSupported - | ResponseBodyTooShort Word64 Word64 - -- ^ Expected size/actual size. - -- - -- Since 1.9.4 - | InvalidChunkHeaders - -- ^ - -- - -- Since 1.9.4 - | IncompleteHeaders - deriving (Show, Typeable) -instance Exception HttpException - - --- 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 (Read, Show) - -newtype CookieJar = CJ { expose :: [Cookie] } - deriving (Read, 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 - --- | Define a HTTP proxy, consisting of a hostname and port number. - -data Proxy = Proxy - { proxyHost :: S.ByteString -- ^ The host name of the HTTP proxy. - , proxyPort :: Int -- ^ The port number of the HTTP proxy. - } - deriving (Show, Read, Eq, Ord, Typeable) - --- | When using one of the --- 'RequestBodySource' \/ 'RequestBodySourceChunked' constructors, --- you must ensure --- that the 'Source' can be called multiple times. Usually this --- is not a problem. --- --- The 'RequestBodySourceChunked' will send a chunked request --- body, note that not all servers support this. Only use --- 'RequestBodySourceChunked' if you know the server you're --- sending to supports chunked request bodies. -data RequestBody - = RequestBodyLBS !L.ByteString - | RequestBodyBS !S.ByteString - | RequestBodyBuilder !Int64 !Builder - | RequestBodyStream !Int64 !(GivesPopper ()) - | RequestBodyStreamChunked !(GivesPopper ()) -instance Monoid RequestBody where - mempty = RequestBodyBS S.empty - mappend x0 y0 = - case (simplify x0, simplify y0) of - (Left (i, x), Left (j, y)) -> RequestBodyBuilder (i + j) (x `mappend` y) - (Left x, Right y) -> combine (builderToStream x) y - (Right x, Left y) -> combine x (builderToStream y) - (Right x, Right y) -> combine x y - where - combine (Just i, x) (Just j, y) = RequestBodyStream (i + j) (combine' x y) - combine (_, x) (_, y) = RequestBodyStreamChunked (combine' x y) - - combine' :: GivesPopper () -> GivesPopper () -> GivesPopper () - combine' x y f = x $ \x' -> y $ \y' -> combine'' x' y' f - - combine'' :: Popper -> Popper -> NeedsPopper () -> IO () - combine'' x y f = do - istate <- newIORef $ Left (x, y) - f $ go istate - - go istate = do - state <- readIORef istate - case state of - Left (x, y) -> do - bs <- x - if S.null bs - then do - writeIORef istate $ Right y - y - else return bs - Right y -> y - -simplify :: RequestBody -> Either (Int64, Builder) (Maybe Int64, GivesPopper ()) -simplify (RequestBodyLBS lbs) = Left (L.length lbs, fromLazyByteString lbs) -simplify (RequestBodyBS bs) = Left (fromIntegral $ S.length bs, fromByteString bs) -simplify (RequestBodyBuilder len b) = Left (len, b) -simplify (RequestBodyStream i gp) = Right (Just i, gp) -simplify (RequestBodyStreamChunked gp) = Right (Nothing, gp) - -builderToStream :: (Int64, Builder) -> (Maybe Int64, GivesPopper ()) -builderToStream (len, builder) = - (Just len, gp) - where - gp np = do - ibss <- newIORef $ L.toChunks $ toLazyByteString builder - np $ do - bss <- readIORef ibss - case bss of - [] -> return S.empty - bs:bss' -> do - writeIORef ibss bss' - return bs - -type Popper = IO S.ByteString -type NeedsPopper a = Popper -> IO a -type GivesPopper a = NeedsPopper a -> IO a - --- | All information on how to connect to a host and what should be sent in the --- HTTP request. --- --- If you simply wish to download from a URL, see 'parseUrl'. --- --- The constructor for this data type is not exposed. Instead, you should use --- either the 'def' method to retrieve a default instance, or 'parseUrl' to --- construct from a URL, and then use the records below to make modifications. --- This approach allows http-conduit to add configuration options without --- breaking backwards compatibility. --- --- For example, to construct a POST request, you could do something like: --- --- > initReq <- parseUrl "http://www.example.com/path" --- > let req = initReq --- > { method = "POST" --- > } --- --- For more information, please see --- . -data Request = Request - { method :: Method - -- ^ HTTP request method, eg GET, POST. - , secure :: Bool - -- ^ Whether to use HTTPS (ie, SSL). - , host :: S.ByteString - , port :: Int - , path :: S.ByteString - -- ^ Everything from the host to the query string. - , queryString :: S.ByteString - , requestHeaders :: RequestHeaders - -- ^ Custom HTTP request headers - -- - -- As already stated in the introduction, the Content-Length and Host - -- headers are set automatically by this module, and shall not be added to - -- requestHeaders. - -- - -- Moreover, the Accept-Encoding header is set implicitly to gzip for - -- convenience by default. This behaviour can be overridden if needed, by - -- setting the header explicitly to a different value. In order to omit the - -- Accept-Header altogether, set it to the empty string \"\". If you need an - -- empty Accept-Header (i.e. requesting the identity encoding), set it to a - -- non-empty white-space string, e.g. \" \". See RFC 2616 section 14.3 for - -- details about the semantics of the Accept-Header field. If you request a - -- content-encoding not supported by this module, you will have to decode - -- it yourself (see also the 'decompress' field). - -- - -- Note: Multiple header fields with the same field-name will result in - -- multiple header fields being sent and therefore it\'s the responsibility - -- of the client code to ensure that the rules from RFC 2616 section 4.2 - -- are honoured. - , requestBody :: RequestBody - , proxy :: Maybe Proxy - -- ^ Optional HTTP proxy. - , hostAddress :: Maybe HostAddress - -- ^ Optional resolved host address. - -- - -- Since 1.8.9 - , rawBody :: Bool - -- ^ If @True@, a chunked and\/or gzipped body will not be - -- decoded. Use with caution. - , decompress :: ContentType -> Bool - -- ^ Predicate to specify whether gzipped data should be - -- decompressed on the fly (see 'alwaysDecompress' and - -- 'browserDecompress'). Default: browserDecompress. - , redirectCount :: Int - -- ^ How many redirects to follow when getting a resource. 0 means follow - -- no redirects. Default value: 10. - , checkStatus :: Status -> 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 - -- ^ Number of microseconds to wait for a response. If @Nothing@, will wait - -- indefinitely. Default: 5 seconds. - , getConnectionWrapper :: Maybe Int - -> HttpException - -> IO (ConnRelease, Connection, ManagedConn) - -> IO (Maybe Int, (ConnRelease, Connection, ManagedConn)) - -- ^ Wraps the calls for getting new connections. This can be useful for - -- instituting some kind of timeouts. The first argument is the value of - -- @responseTimeout@. Second argument is the exception to be thrown on - -- failure. - -- - -- Default: If @responseTimeout@ is @Nothing@, does nothing. Otherwise, - -- institutes timeout, and returns remaining time for @responseTimeout@. - -- - -- 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 - } - -type ContentType = S.ByteString - -data ConnReuse = Reuse | DontReuse - -type ConnRelease = ConnReuse -> IO () - -data ManagedConn = Fresh | Reused - --- | A simple representation of the HTTP response created by 'lbsConsumer'. -data Response body = Response - { responseStatus :: !Status - -- ^ Status code of the response. - , responseVersion :: !HttpVersion - -- ^ HTTP version used by the server. - , responseHeaders :: !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. - , responseClose' :: !ResponseClose - -- ^ Releases any resource held by this response. If the response body - -- has not been fully read yet, doing so after this call will likely - -- be impossible. - } - deriving (Show, Eq, Typeable, Functor) - -responseClose :: Response a -> IO () -responseClose = runResponseClose . responseClose' - -newtype ResponseClose = ResponseClose { runResponseClose :: IO () } - deriving Typeable -instance Show ResponseClose where - show _ = "ResponseClose" -instance Eq ResponseClose where - _ == _ = True diff --git a/src/Network/HTTP/Client/Util.hs b/src/Network/HTTP/Client/Util.hs deleted file mode 100644 --- a/src/Network/HTTP/Client/Util.hs +++ /dev/null @@ -1,84 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleContexts #-} -module Network.HTTP.Client.Util - ( hGetSome - , (<>) - , readDec - , hasNoBody - , fromStrict - ) where - -import Data.Monoid (Monoid, mappend) - -import qualified Data.ByteString.Char8 as S8 -#if MIN_VERSION_bytestring(0,10,0) -import Data.ByteString.Lazy (fromStrict) -#else -import qualified Data.ByteString.Lazy as L -import qualified Data.ByteString as S -#endif - -import qualified Data.Text as T -import qualified Data.Text.Read - -#if MIN_VERSION_base(4,3,0) -import Data.ByteString (hGetSome) -#else -import GHC.IO.Handle.Types -import System.IO (hWaitForInput, hIsEOF) -import System.IO.Error (mkIOError, illegalOperationErrorType) - --- | Like 'hGet', except that a shorter 'ByteString' may be returned --- if there are not enough bytes immediately available to satisfy the --- whole request. 'hGetSome' only blocks if there is no data --- available, and EOF has not yet been reached. -hGetSome :: Handle -> Int -> IO S.ByteString -hGetSome hh i - | i > 0 = let - loop = do - s <- S.hGetNonBlocking hh i - if not (S.null s) - then return s - else do eof <- hIsEOF hh - if eof then return s - else hWaitForInput hh (-1) >> loop - -- for this to work correctly, the - -- Handle should be in binary mode - -- (see GHC ticket #3808) - in loop - | i == 0 = return S.empty - | otherwise = illegalBufferSize hh "hGetSome" i - -illegalBufferSize :: Handle -> String -> Int -> IO a -illegalBufferSize handle fn sz = - ioError (mkIOError illegalOperationErrorType msg (Just handle) Nothing) - --TODO: System.IO uses InvalidArgument here, but it's not exported :-( - where - msg = fn ++ ": illegal ByteString size " ++ showsPrec 9 sz [] -#endif - -infixr 5 <> -(<>) :: Monoid m => m -> m -> m -(<>) = mappend - -readDec :: Integral i => String -> Maybe i -readDec s = - case Data.Text.Read.decimal $ T.pack s of - Right (i, t) - | T.null t -> Just i - _ -> Nothing - -hasNoBody :: S8.ByteString -- ^ request method - -> Int -- ^ status code - -> Bool -hasNoBody "HEAD" _ = True -hasNoBody _ 204 = True -hasNoBody _ 304 = True -hasNoBody _ i = 100 <= i && i < 200 - -#if !MIN_VERSION_bytestring(0,10,0) -{-# INLINE fromStrict #-} -fromStrict :: S.ByteString -> L.ByteString -fromStrict x = L.fromChunks [x] -#endif diff --git a/test/Network/HTTP/Client/BodySpec.hs b/test/Network/HTTP/Client/BodySpec.hs --- a/test/Network/HTTP/Client/BodySpec.hs +++ b/test/Network/HTTP/Client/BodySpec.hs @@ -2,8 +2,8 @@ module Network.HTTP.Client.BodySpec where import Test.Hspec -import Network.HTTP.Client.Body -import Network.HTTP.Client.Connection +import Network.HTTP.Client +import Network.HTTP.Client.Internal import qualified Data.ByteString as S import Codec.Compression.GZip (compress) import qualified Data.ByteString.Lazy as L diff --git a/test/Network/HTTP/Client/HeadersSpec.hs b/test/Network/HTTP/Client/HeadersSpec.hs --- a/test/Network/HTTP/Client/HeadersSpec.hs +++ b/test/Network/HTTP/Client/HeadersSpec.hs @@ -1,9 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} module Network.HTTP.Client.HeadersSpec where -import Network.HTTP.Client.Connection -import Network.HTTP.Client.Headers -import Network.HTTP.Client.Types +import Network.HTTP.Client +import Network.HTTP.Client.Internal import Network.HTTP.Types import Test.Hspec diff --git a/test/Network/HTTP/Client/ResponseSpec.hs b/test/Network/HTTP/Client/ResponseSpec.hs --- a/test/Network/HTTP/Client/ResponseSpec.hs +++ b/test/Network/HTTP/Client/ResponseSpec.hs @@ -3,10 +3,8 @@ module Network.HTTP.Client.ResponseSpec where import Test.Hspec -import Network.HTTP.Client.Request -import Network.HTTP.Client.Response -import Network.HTTP.Client.Connection -import Network.HTTP.Client.Body +import Network.HTTP.Client +import Network.HTTP.Client.Internal import Network.HTTP.Types import Codec.Compression.GZip (compress) import qualified Data.ByteString.Lazy as L diff --git a/test/Network/HTTP/ClientSpec.hs b/test/Network/HTTP/ClientSpec.hs --- a/test/Network/HTTP/ClientSpec.hs +++ b/test/Network/HTTP/ClientSpec.hs @@ -1,12 +1,8 @@ -{-# LANGUAGE RecordWildCards #-} module Network.HTTP.ClientSpec where import Data.Default import Network.HTTP.Client -import Network.HTTP.Client.Manager -import Network.HTTP.Client.Request -import Network.HTTP.Client.Types -import Network.HTTP.Types +import Network.HTTP.Types (status200) import Test.Hspec main :: IO () @@ -17,5 +13,5 @@ it "works" $ do req <- parseUrl "http://www.yesodweb.com/" man <- newManager defaultManagerSettings - Response {..} <- httpLbs req man - responseStatus `shouldBe` status200 + res <- httpLbs req man + responseStatus res `shouldBe` status200