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