http-client (empty) → 0.1.0.0
raw patch · 19 files changed
+2442/−0 lines, 19 filesdep +basedep +base64-bytestringdep +blaze-buildersetup-changed
Dependencies added: base, base64-bytestring, blaze-builder, bytestring, case-insensitive, containers, cookie, data-default, deepseq, failure, hspec, http-client, http-types, monad-control, network, publicsuffixlist, text, time, transformers, zlib, zlib-bindings
Files
- LICENSE +20/−0
- README.md +4/−0
- Setup.hs +2/−0
- http-client.cabal +75/−0
- src/Network/HTTP/Client.hs +199/−0
- src/Network/HTTP/Client/Body.hs +194/−0
- src/Network/HTTP/Client/Connection.hs +132/−0
- src/Network/HTTP/Client/Cookies.hs +246/−0
- src/Network/HTTP/Client/Headers.hs +75/−0
- src/Network/HTTP/Client/Manager.hs +371/−0
- src/Network/HTTP/Client/Request.hs +343/−0
- src/Network/HTTP/Client/Response.hs +140/−0
- src/Network/HTTP/Client/Types.hs +327/−0
- src/Network/HTTP/Client/Util.hs +84/−0
- test/Network/HTTP/Client/BodySpec.hs +79/−0
- test/Network/HTTP/Client/HeadersSpec.hs +29/−0
- test/Network/HTTP/Client/ResponseSpec.hs +89/−0
- test/Network/HTTP/ClientSpec.hs +21/−0
- test/Spec.hs +12/−0
+ LICENSE view
@@ -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.
+ README.md view
@@ -0,0 +1,4 @@+http-client+===========++An HTTP client engine, intended as a base layer for more user-friendly packages.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ http-client.cabal view
@@ -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
+ src/Network/HTTP/Client.hs view
@@ -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
+ src/Network/HTTP/Client/Body.hs view
@@ -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
+ src/Network/HTTP/Client/Connection.hs view
@@ -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
+ src/Network/HTTP/Client/Cookies.hs view
@@ -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)
+ src/Network/HTTP/Client/Headers.hs view
@@ -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)
+ src/Network/HTTP/Client/Manager.hs view
@@ -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)
+ src/Network/HTTP/Client/Request.hs view
@@ -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"
+ src/Network/HTTP/Client/Response.hs view
@@ -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)+ }
+ src/Network/HTTP/Client/Types.hs view
@@ -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+-- <http://www.yesodweb.com/book/settings-types>.+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
+ src/Network/HTTP/Client/Util.hs view
@@ -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
+ test/Network/HTTP/Client/BodySpec.hs view
@@ -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
+ test/Network/HTTP/Client/HeadersSpec.hs view
@@ -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")+ ]
+ test/Network/HTTP/Client/ResponseSpec.hs view
@@ -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"
+ test/Network/HTTP/ClientSpec.hs view
@@ -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
+ test/Spec.hs view
@@ -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