diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +The MIT License (MIT) + +Copyright (c) 2013 Michael Snoyman + +Permission is hereby granted, free of charge, to any person obtaining a copy of +this software and associated documentation files (the "Software"), to deal in +the Software without restriction, including without limitation the rights to +use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of +the Software, and to permit persons to whom the Software is furnished to do so, +subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS +FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR +COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER +IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,4 @@ +http-client +=========== + +An HTTP client engine, intended as a base layer for more user-friendly packages. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/http-client.cabal b/http-client.cabal new file mode 100644 --- /dev/null +++ b/http-client.cabal @@ -0,0 +1,75 @@ +name: http-client +version: 0.1.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 +author: Michael Snoyman +maintainer: michael@snoyman.com +category: Network +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +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.Headers + 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 + , data-default + , 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 + , publicsuffixlist + , cookie + hs-source-dirs: src + default-language: Haskell2010 + +test-suite spec + main-is: Spec.hs + type: exitcode-stdio-1.0 + hs-source-dirs: test + default-language: Haskell2010 + other-modules: Network.HTTP.ClientSpec + Network.HTTP.Client.ResponseSpec + Network.HTTP.Client.BodySpec + Network.HTTP.Client.HeadersSpec + build-depends: base + , http-client + , hspec + , monad-control + , bytestring + , text + , http-types + , blaze-builder + , data-default + , time + , network + , zlib-bindings + , containers + , transformers + , deepseq + , case-insensitive + , failure + , base64-bytestring + , zlib diff --git a/src/Network/HTTP/Client.hs b/src/Network/HTTP/Client.hs new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/Client.hs @@ -0,0 +1,199 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/Client/Body.hs @@ -0,0 +1,194 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/Client/Connection.hs @@ -0,0 +1,132 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/Client/Cookies.hs @@ -0,0 +1,246 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/Client/Headers.hs @@ -0,0 +1,75 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/Client/Manager.hs @@ -0,0 +1,371 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/Client/Request.hs @@ -0,0 +1,343 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/Client/Response.hs @@ -0,0 +1,140 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/Client/Types.hs @@ -0,0 +1,327 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/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/test/Network/HTTP/Client/BodySpec.hs b/test/Network/HTTP/Client/BodySpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/HTTP/Client/BodySpec.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE OverloadedStrings #-} +module Network.HTTP.Client.BodySpec where + +import Test.Hspec +import Network.HTTP.Client.Body +import Network.HTTP.Client.Connection +import qualified Data.ByteString as S +import Codec.Compression.GZip (compress) +import qualified Data.ByteString.Lazy as L + +main :: IO () +main = hspec spec + +spec :: Spec +spec = describe "BodySpec" $ do + it "chunked, single" $ do + (conn, _, input) <- dummyConnection + [ "5\r\nhello\r\n6\r\n world\r\n0\r\nnot consumed" + ] + reader <- makeChunkedReader False conn + complete1 <- brComplete reader + complete1 `shouldBe` False + body <- brConsume reader + S.concat body `shouldBe` "hello world" + input' <- input + S.concat input' `shouldBe` "not consumed" + complete2 <- brComplete reader + complete2 `shouldBe` True + it "chunked, pieces" $ do + (conn, _, input) <- dummyConnection $ map S.singleton $ S.unpack + "5\r\nhello\r\n6\r\n world\r\n0\r\nnot consumed" + reader <- makeChunkedReader False conn + complete1 <- brComplete reader + complete1 `shouldBe` False + body <- brConsume reader + S.concat body `shouldBe` "hello world" + input' <- input + S.concat input' `shouldBe` "not consumed" + complete2 <- brComplete reader + complete2 `shouldBe` True + it "length, single" $ do + (conn, _, input) <- dummyConnection + [ "hello world done" + ] + reader <- makeLengthReader 11 conn + complete1 <- brComplete reader + complete1 `shouldBe` False + body <- brConsume reader + S.concat body `shouldBe` "hello world" + input' <- input + S.concat input' `shouldBe` " done" + complete2 <- brComplete reader + complete2 `shouldBe` True + it "length, pieces" $ do + (conn, _, input) <- dummyConnection $ map S.singleton $ S.unpack + "hello world done" + reader <- makeLengthReader 11 conn + complete1 <- brComplete reader + complete1 `shouldBe` False + body <- brConsume reader + S.concat body `shouldBe` "hello world" + input' <- input + S.concat input' `shouldBe` " done" + complete2 <- brComplete reader + complete2 `shouldBe` True + it "gzip" $ do + let orig = L.fromChunks $ replicate 5000 "Hello world!" + origZ = compress orig + (conn, _, input) <- dummyConnection $ L.toChunks origZ ++ ["ignored"] + reader' <- makeLengthReader (fromIntegral $ L.length origZ) conn + reader <- makeGzipReader reader' + complete1 <- brComplete reader + complete1 `shouldBe` False + body <- brConsume reader + L.fromChunks body `shouldBe` orig + input' <- input + S.concat input' `shouldBe` "ignored" + complete2 <- brComplete reader + complete2 `shouldBe` True diff --git a/test/Network/HTTP/Client/HeadersSpec.hs b/test/Network/HTTP/Client/HeadersSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/HTTP/Client/HeadersSpec.hs @@ -0,0 +1,29 @@ +{-# 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.Types +import Test.Hspec + +main :: IO () +main = hspec spec + +spec :: Spec +spec = describe "HeadersSpec" $ do + it "simple response" $ do + let input = + [ "HTTP/" + , "1.1 200" + , " OK\r\nfoo" + , ": bar\r\n" + , "baz:bin\r\n\r" + , "\nignored" + ] + (connection, getOutput, getInput) <- dummyConnection input + statusHeaders <- parseStatusHeaders connection + statusHeaders `shouldBe` StatusHeaders status200 (HttpVersion 1 1) + [ ("foo", "bar") + , ("baz", "bin") + ] diff --git a/test/Network/HTTP/Client/ResponseSpec.hs b/test/Network/HTTP/Client/ResponseSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/HTTP/Client/ResponseSpec.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +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.Types +import Codec.Compression.GZip (compress) +import qualified Data.ByteString.Lazy as L +import Data.ByteString.Lazy.Char8 () +import qualified Data.ByteString as S + +main :: IO () +main = hspec spec + +spec :: Spec +spec = describe "ResponseSpec" $ do + let getResponse' conn = getResponse (const $ return ()) Nothing req conn + Just req = parseUrl "http://localhost" + it "basic" $ do + (conn, getOutput, getInput) <- dummyConnection + [ "HTTP/1.1 200 OK\r\n" + , "Key1: Value1\r\n" + , "Content-length: 11\r\n\r\n" + , "Hello" + , " W" + , "orld\r\nHTTP/1.1" + ] + Response {..} <- getResponse' conn + responseStatus `shouldBe` status200 + responseVersion `shouldBe` HttpVersion 1 1 + responseHeaders `shouldBe` + [ ("Key1", "Value1") + , ("Content-length", "11") + ] + pieces <- brConsume responseBody + pieces `shouldBe` ["Hello", " W", "orld"] + it "no length" $ do + (conn, getOutput, getInput) <- dummyConnection + [ "HTTP/1.1 200 OK\r\n" + , "Key1: Value1\r\n\r\n" + , "Hello" + , " W" + , "orld\r\nHTTP/1.1" + ] + Response {..} <- getResponse' conn + responseStatus `shouldBe` status200 + responseVersion `shouldBe` HttpVersion 1 1 + responseHeaders `shouldBe` + [ ("Key1", "Value1") + ] + pieces <- brConsume responseBody + pieces `shouldBe` ["Hello", " W", "orld\r\nHTTP/1.1"] + it "chunked" $ do + (conn, getOutput, getInput) <- dummyConnection + [ "HTTP/1.1 200 OK\r\n" + , "Key1: Value1\r\n" + , "Transfer-encoding: chunked\r\n\r\n" + , "5\r\nHello\r" + , "\n2\r\n W" + , "\r\n4 ignored\r\norld\r\n0\r\nHTTP/1.1" + ] + Response {..} <- getResponse' conn + responseStatus `shouldBe` status200 + responseVersion `shouldBe` HttpVersion 1 1 + responseHeaders `shouldBe` + [ ("Key1", "Value1") + , ("Transfer-encoding", "chunked") + ] + pieces <- brConsume responseBody + pieces `shouldBe` ["Hello", " W", "orld"] + it "gzip" $ do + (conn, getOutput, getInput) <- dummyConnection + $ "HTTP/1.1 200 OK\r\n" + : "Key1: Value1\r\n" + : "Content-Encoding: gzip\r\n\r\n" + : L.toChunks (compress "Compressed Hello World") + Response {..} <- getResponse' conn + responseStatus `shouldBe` status200 + responseVersion `shouldBe` HttpVersion 1 1 + responseHeaders `shouldBe` + [ ("Key1", "Value1") + , ("Content-Encoding", "gzip") + ] + pieces <- brConsume responseBody + S.concat pieces `shouldBe` "Compressed Hello World" diff --git a/test/Network/HTTP/ClientSpec.hs b/test/Network/HTTP/ClientSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/HTTP/ClientSpec.hs @@ -0,0 +1,21 @@ +{-# 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 Test.Hspec + +main :: IO () +main = hspec spec + +spec :: Spec +spec = describe "Client" $ do + it "works" $ do + req <- parseUrl "http://www.yesodweb.com/" + man <- newManager defaultManagerSettings + Response {..} <- httpLbs req man + responseStatus `shouldBe` status200 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,12 @@ +import Test.Hspec +import qualified Network.HTTP.Client.BodySpec as BodySpec +import qualified Network.HTTP.Client.HeadersSpec as HeadersSpec +import qualified Network.HTTP.Client.ResponseSpec as ResponseSpec +import qualified Network.HTTP.ClientSpec as ClientSpec + +main :: IO () +main = hspec $ do + BodySpec.spec + HeadersSpec.spec + ResponseSpec.spec + ClientSpec.spec