http-conduit-2.3.7.1/Network/0000755000000000000000000000000012632352123014122 5ustar0000000000000000http-conduit-2.3.7.1/Network/HTTP/0000755000000000000000000000000013462041617014706 5ustar0000000000000000http-conduit-2.3.7.1/Network/HTTP/Client/0000755000000000000000000000000013441433547016130 5ustar0000000000000000http-conduit-2.3.7.1/test/0000755000000000000000000000000013462041647013460 5ustar0000000000000000http-conduit-2.3.7.1/Network/HTTP/Conduit.hs0000644000000000000000000003142213441662072016652 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -- | -- -- = Simpler API -- -- The API below is rather low-level. The "Network.HTTP.Simple" module provides -- a higher-level API with built-in support for things like JSON request and -- response bodies. For most users, this will be an easier place to start. You -- can read the tutorial at: -- -- -- -- = Lower-level API -- -- This module contains everything you need to initiate HTTP connections. If -- you want a simple interface based on URLs, you can use 'simpleHttp'. If you -- want raw power, 'http' is the underlying workhorse of this package. Some -- examples: -- -- > -- Just download an HTML document and print it. -- > import Network.HTTP.Conduit -- > import qualified Data.ByteString.Lazy as L -- > -- > main = simpleHttp "http://www.haskell.org/" >>= L.putStr -- -- This example uses interleaved IO to write the response body to a file in -- constant memory space. -- -- > import Data.Conduit.Binary (sinkFile) -- Exported from the package conduit-extra -- > import Network.HTTP.Conduit -- > import Conduit (runConduit, (.|)) -- > import Control.Monad.Trans.Resource (runResourceT) -- > -- > main :: IO () -- > main = do -- > request <- parseRequest "http://google.com/" -- > manager <- newManager tlsManagerSettings -- > runResourceT $ do -- > response <- http request manager -- > runConduit $ responseBody response .| sinkFile "google.html" -- -- The following headers are automatically set by this module, and should not -- be added to 'requestHeaders': -- -- * Cookie -- -- * Content-Length -- -- * Transfer-Encoding -- -- Note: In previous versions, the Host header would be set by this module in -- all cases. Starting from 1.6.1, if a Host header is present in -- @requestHeaders@, it will be used in place of the header this module would -- have generated. This can be useful for calling a server which utilizes -- virtual hosting. -- -- Use `cookieJar` If you want to supply cookies with your request: -- -- > {-# LANGUAGE OverloadedStrings #-} -- > import Network.HTTP.Conduit -- > import Network -- > import Data.Time.Clock -- > import Data.Time.Calendar -- > import qualified Control.Exception as E -- > import Network.HTTP.Types.Status (statusCode) -- > -- > past :: UTCTime -- > past = UTCTime (ModifiedJulianDay 56200) (secondsToDiffTime 0) -- > -- > future :: UTCTime -- > future = UTCTime (ModifiedJulianDay 562000) (secondsToDiffTime 0) -- > -- > cookie :: Cookie -- > cookie = Cookie { cookie_name = "password_hash" -- > , cookie_value = "abf472c35f8297fbcabf2911230001234fd2" -- > , cookie_expiry_time = future -- > , cookie_domain = "example.com" -- > , cookie_path = "/" -- > , cookie_creation_time = past -- > , cookie_last_access_time = past -- > , cookie_persistent = False -- > , cookie_host_only = False -- > , cookie_secure_only = False -- > , cookie_http_only = False -- > } -- > -- > main = do -- > request' <- parseRequest "http://example.com/secret-page" -- > manager <- newManager tlsManagerSettings -- > let request = request' { cookieJar = Just $ createCookieJar [cookie] } -- > fmap Just (httpLbs request manager) `E.catch` -- > (\ex -> case ex of -- > HttpExceptionRequest _ (StatusCodeException res _) -> -- > if statusCode (responseStatus res) == 403 -- > then (putStrLn "login failed" >> return Nothing) -- > else return Nothing -- > _ -> E.throw ex) -- -- Cookies are implemented according to RFC 6265. -- -- Note that by default, the functions in this package will throw exceptions -- for non-2xx status codes. If you would like to avoid this, you should use -- 'checkStatus', e.g.: -- -- > import Data.Conduit.Binary (sinkFile) -- > import Network.HTTP.Conduit -- > import qualified Data.Conduit as C -- > import Network -- > -- > main :: IO () -- > main = do -- > request' <- parseRequest "http://www.yesodweb.com/does-not-exist" -- > let request = request' { checkStatus = \_ _ _ -> Nothing } -- > manager <- newManager tlsManagerSettings -- > res <- httpLbs request manager -- > print res -- -- By default, when connecting to websites using HTTPS, functions in this -- package will throw an exception if the TLS certificate doesn't validate. To -- continue the HTTPS transaction even if the TLS cerficate validation fails, -- you should use 'mkManagerSetttings' as follows: -- -- > import Network.Connection (TLSSettings (..)) -- > import Network.HTTP.Conduit -- > -- > main :: IO () -- > main = do -- > request <- parseRequest "https://github.com/" -- > let settings = mkManagerSettings (TLSSettingsSimple True False False) Nothing -- > manager <- newManager settings -- > res <- httpLbs request manager -- > print res -- -- For more information, please be sure to read the documentation in the -- "Network.HTTP.Client" module. module Network.HTTP.Conduit ( -- * Perform a request simpleHttp , httpLbs , http -- * Datatypes , Proxy (..) , RequestBody (..) -- ** Request , Request , method , secure , host , port , path , queryString , requestHeaders , requestBody , proxy , hostAddress , rawBody , decompress , redirectCount #if MIN_VERSION_http_client(0,6,2) , shouldStripHeaderOnRedirect #endif , checkResponse , responseTimeout , cookieJar , requestVersion , HCC.setQueryString -- *** Request body , requestBodySource , requestBodySourceChunked , requestBodySourceIO , requestBodySourceChunkedIO -- * Response , Response , responseStatus , responseVersion , responseHeaders , responseBody , responseCookieJar -- * Manager , Manager , newManager , closeManager -- ** Settings , ManagerSettings , tlsManagerSettings , mkManagerSettings , managerConnCount , managerResponseTimeout , managerTlsConnection -- ** Response timeout , HC.ResponseTimeout , HC.responseTimeoutMicro , HC.responseTimeoutNone , HC.responseTimeoutDefault -- * Cookies , Cookie(..) , CookieJar , createCookieJar , destroyCookieJar -- * Utility functions , parseUrl , parseUrlThrow , parseRequest , parseRequest_ , defaultRequest , applyBasicAuth , addProxy , lbsResponse , getRedirectedRequest -- * Decompression predicates , alwaysDecompress , browserDecompress -- * Request bodies -- | "Network.HTTP.Client.MultipartFormData" provides an API for building -- form-data request bodies. , urlEncodedBody -- * Exceptions , HttpException (..) , HCC.HttpExceptionContent (..) ) where import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import Data.Conduit import qualified Data.Conduit.List as CL import Data.IORef (readIORef, writeIORef, newIORef) import Data.Int (Int64) import Control.Applicative as A ((<$>)) import Control.Monad.IO.Unlift (MonadIO (liftIO)) import Control.Monad.Trans.Resource import qualified Network.HTTP.Client as Client (httpLbs, responseOpen, responseClose) import qualified Network.HTTP.Client as HC import qualified Network.HTTP.Client.Conduit as HCC import Network.HTTP.Client.Internal (createCookieJar, destroyCookieJar) import Network.HTTP.Client.Internal (Manager, ManagerSettings, closeManager, managerConnCount, managerResponseTimeout, managerTlsConnection, newManager) import Network.HTTP.Client (parseUrl, parseUrlThrow, urlEncodedBody, applyBasicAuth, defaultRequest, parseRequest, parseRequest_) import Network.HTTP.Client.Internal (addProxy, alwaysDecompress, browserDecompress) import Network.HTTP.Client.Internal (getRedirectedRequest) import Network.HTTP.Client.TLS (mkManagerSettings, tlsManagerSettings) import Network.HTTP.Client.Internal (Cookie (..), CookieJar (..), HttpException (..), Proxy (..), Request (..), RequestBody (..), Response (..)) -- | Download the specified 'Request', returning the results as a 'Response'. -- -- This is a simplified version of 'http' for the common case where you simply -- want the response data as a simple datatype. If you want more power, such as -- interleaved actions on the response body during download, you'll need to use -- 'http' directly. This function is defined as: -- -- @httpLbs = 'lbsResponse' <=< 'http'@ -- -- Even though the 'Response' contains a lazy bytestring, this -- function does /not/ utilize lazy I/O, and therefore the entire -- response body will live in memory. If you want constant memory -- usage, you'll need to use @conduit@ packages's -- 'C.Source' returned by 'http'. -- -- This function will 'throwIO' an 'HttpException' for any -- response with a non-2xx status code (besides 3xx redirects up -- to a limit of 10 redirects). This behavior can be modified by -- changing the 'checkStatus' field of your request. -- -- Note: Unlike previous versions, this function will perform redirects, as -- specified by the 'redirectCount' setting. httpLbs :: MonadIO m => Request -> Manager -> m (Response L.ByteString) httpLbs r m = liftIO $ Client.httpLbs r m -- | Download the specified URL, following any redirects, and -- return the response body. -- -- This function will 'throwIO' an 'HttpException' for any -- response with a non-2xx status code (besides 3xx redirects up -- to a limit of 10 redirects). It uses 'parseUrlThrow' to parse the -- input. This function essentially wraps 'httpLbs'. -- -- Note: Even though this function returns a lazy bytestring, it -- does /not/ utilize lazy I/O, and therefore the entire response -- body will live in memory. If you want constant memory usage, -- you'll need to use the @conduit@ package and 'http' directly. -- -- Note: This function creates a new 'Manager'. It should be avoided -- in production code. simpleHttp :: MonadIO m => String -> m L.ByteString simpleHttp url = liftIO $ do man <- newManager tlsManagerSettings req <- liftIO $ parseUrlThrow url responseBody A.<$> httpLbs (setConnectionClose req) man setConnectionClose :: Request -> Request setConnectionClose req = req{requestHeaders = ("Connection", "close") : requestHeaders req} lbsResponse :: Monad m => Response (ConduitM () S.ByteString m ()) -> m (Response L.ByteString) lbsResponse res = do bss <- runConduit $ responseBody res .| CL.consume return res { responseBody = L.fromChunks bss } http :: MonadResource m => Request -> Manager -> m (Response (ConduitM i S.ByteString m ())) http req man = do (key, res) <- allocate (Client.responseOpen req man) Client.responseClose return res { responseBody = do HCC.bodyReaderSource $ responseBody res release key } requestBodySource :: Int64 -> ConduitM () S.ByteString (ResourceT IO) () -> RequestBody requestBodySource size = RequestBodyStream size . srcToPopper requestBodySourceChunked :: ConduitM () S.ByteString (ResourceT IO) () -> RequestBody requestBodySourceChunked = RequestBodyStreamChunked . srcToPopper srcToPopper :: ConduitM () S.ByteString (ResourceT IO) () -> HCC.GivesPopper () srcToPopper src f = runResourceT $ do (rsrc0, ()) <- src $$+ return () irsrc <- liftIO $ newIORef rsrc0 is <- getInternalState let popper :: IO S.ByteString popper = do rsrc <- readIORef irsrc (rsrc', mres) <- runInternalState (rsrc $$++ await) is writeIORef irsrc rsrc' case mres of Nothing -> return S.empty Just bs | S.null bs -> popper | otherwise -> return bs liftIO $ f popper requestBodySourceIO :: Int64 -> ConduitM () S.ByteString IO () -> RequestBody requestBodySourceIO = HCC.requestBodySource requestBodySourceChunkedIO :: ConduitM () S.ByteString IO () -> RequestBody requestBodySourceChunkedIO = HCC.requestBodySourceChunked http-conduit-2.3.7.1/Network/HTTP/Client/Conduit.hs0000644000000000000000000001465313441433547020102 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} -- | A new, experimental API to replace "Network.HTTP.Conduit". -- -- For most users, "Network.HTTP.Simple" is probably a better choice. For more -- information, see: -- -- -- -- For more information on using this module, please be sure to read the -- documentation in the "Network.HTTP.Client" module. module Network.HTTP.Client.Conduit ( -- * Conduit-specific interface withResponse , responseOpen , responseClose , acquireResponse , httpSource -- * Manager helpers , defaultManagerSettings , newManager , newManagerSettings -- * General HTTP client interface , module Network.HTTP.Client , httpLbs , httpNoBody -- * Lower-level conduit functions , requestBodySource , requestBodySourceChunked , bodyReaderSource ) where import Control.Monad (unless) import Control.Monad.IO.Unlift (MonadIO, liftIO, MonadUnliftIO, withRunInIO) import Control.Monad.Reader (MonadReader (..), runReaderT) import Control.Monad.Trans.Resource (MonadResource) import Data.Acquire (Acquire, mkAcquire, with) import Data.ByteString (ByteString) import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import Data.Conduit (ConduitM, ($$+), ($$++), await, yield, bracketP) import Data.Int (Int64) import Data.IORef (newIORef, readIORef, writeIORef) import Network.HTTP.Client hiding (closeManager, defaultManagerSettings, httpLbs, newManager, responseClose, responseOpen, withResponse, BodyReader, brRead, brConsume, httpNoBody) import qualified Network.HTTP.Client as H import Network.HTTP.Client.TLS (tlsManagerSettings) -- | Conduit powered version of 'H.withResponse'. Differences are: -- -- * Response body is represented as a @Producer@. -- -- * Generalized to any instance of @MonadUnliftIO@, not just @IO@. -- -- * The @Manager@ is contained by a @MonadReader@ context. -- -- Since 2.1.0 withResponse :: (MonadUnliftIO m, MonadIO n, MonadReader env m, HasHttpManager env) => Request -> (Response (ConduitM i ByteString n ()) -> m a) -> m a withResponse req f = do env <- ask withRunInIO $ \run -> with (acquireResponse req env) (run . f) -- | An @Acquire@ for getting a @Response@. -- -- Since 2.1.0 acquireResponse :: (MonadIO n, MonadReader env m, HasHttpManager env) => Request -> m (Acquire (Response (ConduitM i ByteString n ()))) acquireResponse req = do env <- ask let man = getHttpManager env return $ do res <- mkAcquire (H.responseOpen req man) H.responseClose return $ fmap bodyReaderSource res -- | TLS-powered manager settings. -- -- Since 2.1.0 defaultManagerSettings :: ManagerSettings defaultManagerSettings = tlsManagerSettings -- | Get a new manager using 'defaultManagerSettings'. -- -- Since 2.1.0 newManager :: MonadIO m => m Manager newManager = newManagerSettings defaultManagerSettings -- | Get a new manager using the given settings. -- -- Since 2.1.0 newManagerSettings :: MonadIO m => ManagerSettings -> m Manager newManagerSettings = liftIO . H.newManager -- | Conduit-powered version of 'H.responseOpen'. -- -- See 'withResponse' for the differences with 'H.responseOpen'. -- -- Since 2.1.0 responseOpen :: (MonadIO m, MonadIO n, MonadReader env m, HasHttpManager env) => Request -> m (Response (ConduitM i ByteString n ())) responseOpen req = do env <- ask liftIO $ fmap bodyReaderSource `fmap` H.responseOpen req (getHttpManager env) -- | Generalized version of 'H.responseClose'. -- -- Since 2.1.0 responseClose :: MonadIO m => Response body -> m () responseClose = liftIO . H.responseClose bodyReaderSource :: MonadIO m => H.BodyReader -> ConduitM i ByteString m () bodyReaderSource br = loop where loop = do bs <- liftIO $ H.brRead br unless (S.null bs) $ do yield bs loop requestBodySource :: Int64 -> ConduitM () ByteString IO () -> RequestBody requestBodySource size = RequestBodyStream size . srcToPopperIO requestBodySourceChunked :: ConduitM () ByteString IO () -> RequestBody requestBodySourceChunked = RequestBodyStreamChunked . srcToPopperIO srcToPopperIO :: ConduitM () ByteString IO () -> GivesPopper () srcToPopperIO src f = do (rsrc0, ()) <- src $$+ return () irsrc <- newIORef rsrc0 let popper :: IO ByteString popper = do rsrc <- readIORef irsrc (rsrc', mres) <- rsrc $$++ await writeIORef irsrc rsrc' case mres of Nothing -> return S.empty Just bs | S.null bs -> popper | otherwise -> return bs f popper -- | Same as 'H.httpLbs', except it uses the @Manager@ in the reader environment. -- -- Since 2.1.1 httpLbs :: (MonadIO m, HasHttpManager env, MonadReader env m) => Request -> m (Response L.ByteString) httpLbs req = do env <- ask let man = getHttpManager env liftIO $ H.httpLbs req man -- | Same as 'H.httpNoBody', except it uses the @Manager@ in the reader environment. -- -- This can be more convenient that using 'withManager' as it avoids the need -- to specify the base monad for the response body. -- -- Since 2.1.2 httpNoBody :: (MonadIO m, HasHttpManager env, MonadReader env m) => Request -> m (Response ()) httpNoBody req = do env <- ask let man = getHttpManager env liftIO $ H.httpNoBody req man -- | Same as 'Network.HTTP.Simple.httpSource', but uses 'Manager' -- from Reader environment instead of the global one. -- -- Since 2.3.6 httpSource :: (MonadResource m, MonadIO n, MonadReader env m, HasHttpManager env) => Request -> (Response (ConduitM () ByteString n ()) -> ConduitM () r m ()) -> ConduitM () r m () httpSource request withRes = do env <- ask bracketP (runReaderT (responseOpen request) env) responseClose withRes http-conduit-2.3.7.1/Network/HTTP/Simple.hs0000644000000000000000000003704513462041617016504 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE OverloadedStrings #-} -- | Simplified interface for common HTTP client interactions. Tutorial -- available at -- -- -- Important note: 'H.Request' is an instance of 'Data.String.IsString', and -- therefore recommended usage is to turn on @OverloadedStrings@, e.g. -- -- > {-# LANGUAGE OverloadedStrings #-} -- > import Network.HTTP.Simple -- > import qualified Data.ByteString.Char8 as B8 -- > -- > main :: IO () -- > main = httpBS "http://example.com" >>= B8.putStrLn . getResponseBody -- -- The `Data.String.IsString` instance uses `H.parseRequest` behind the scenes and inherits its behavior. module Network.HTTP.Simple ( -- * Perform requests httpBS , httpLBS , httpNoBody , httpJSON , httpJSONEither , httpSink , httpSource , withResponse -- * Types , H.Header , H.Query , H.QueryItem , H.Request , H.RequestHeaders , H.Response , H.ResponseHeaders , JSONException (..) , H.HttpException (..) , H.Proxy (..) -- * Request constructions , H.defaultRequest , H.parseRequest , H.parseRequest_ , parseRequestThrow , parseRequestThrow_ -- * Request lenses -- ** Basics , setRequestMethod , setRequestSecure , setRequestHost , setRequestPort , setRequestPath , addRequestHeader , getRequestHeader , setRequestHeader , setRequestHeaders , setRequestQueryString , getRequestQueryString , addToRequestQueryString -- ** Request body , setRequestBody , setRequestBodyJSON , setRequestBodyLBS , setRequestBodySource , setRequestBodyFile , setRequestBodyURLEncoded -- ** Special fields , H.setRequestIgnoreStatus , H.setRequestCheckStatus , setRequestBasicAuth , setRequestManager , setRequestProxy -- * Response lenses , getResponseStatus , getResponseStatusCode , getResponseHeader , getResponseHeaders , getResponseBody -- * Alternate spellings , httpLbs ) where import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import qualified Network.HTTP.Client as H import qualified Network.HTTP.Client.Internal as HI import qualified Network.HTTP.Client.TLS as H import Network.HTTP.Client.Conduit (bodyReaderSource) import qualified Network.HTTP.Client.Conduit as HC import Control.Monad.IO.Unlift (MonadIO, liftIO, MonadUnliftIO, withRunInIO) import Data.Aeson (FromJSON (..), Value) import Data.Aeson.Parser (json') import qualified Data.Aeson.Types as A import qualified Data.Aeson as A import qualified Data.Traversable as T import Control.Exception (throw, throwIO, Exception) import Data.Monoid import Data.Typeable (Typeable) import qualified Data.Conduit as C import Data.Conduit (runConduit, (.|), ConduitM) import qualified Data.Conduit.Attoparsec as C import qualified Network.HTTP.Types as H import Data.Int (Int64) import Control.Monad.Trans.Resource (MonadResource, MonadThrow) import qualified Control.Exception as E (bracket) import Data.Void (Void) import qualified Data.Attoparsec.ByteString as Atto import qualified Data.Attoparsec.ByteString.Char8 as Atto8 -- | Perform an HTTP request and return the body as a @ByteString@. -- -- @since 2.2.4 httpBS :: MonadIO m => H.Request -> m (H.Response S.ByteString) httpBS req = liftIO $ do man <- H.getGlobalManager fmap L.toStrict `fmap` H.httpLbs req man -- | Perform an HTTP request and return the body as a lazy -- @ByteString@. Note that the entire value will be read into memory -- at once (no lazy I\/O will be performed). The advantage of a lazy -- @ByteString@ here (versus using 'httpBS') is--if needed--a better -- in-memory representation. -- -- @since 2.1.10 httpLBS :: MonadIO m => H.Request -> m (H.Response L.ByteString) httpLBS req = liftIO $ do man <- H.getGlobalManager H.httpLbs req man -- | Perform an HTTP request and ignore the response body. -- -- @since 2.2.2 httpNoBody :: MonadIO m => H.Request -> m (H.Response ()) httpNoBody req = liftIO $ do man <- H.getGlobalManager H.httpNoBody req man -- | Perform an HTTP request and parse the body as JSON. In the event of an -- JSON parse errors, a 'JSONException' runtime exception will be thrown. -- -- @since 2.1.10 httpJSON :: (MonadIO m, FromJSON a) => H.Request -> m (H.Response a) httpJSON req = liftIO $ httpJSONEither req >>= T.mapM (either throwIO return) -- | Perform an HTTP request and parse the body as JSON. In the event of an -- JSON parse errors, a @Left@ value will be returned. -- -- @since 2.1.10 httpJSONEither :: (MonadIO m, FromJSON a) => H.Request -> m (H.Response (Either JSONException a)) httpJSONEither req = liftIO $ httpSink req' sink where req' = addRequestHeader H.hAccept "application/json" req sink orig = fmap (\x -> fmap (const x) orig) $ do eres1 <- C.sinkParserEither (json' <* (Atto8.skipSpace *> Atto.endOfInput)) case eres1 of Left e -> return $ Left $ JSONParseException req' orig e Right value -> case A.fromJSON value of A.Error e -> return $ Left $ JSONConversionException req' (fmap (const value) orig) e A.Success x -> return $ Right x -- | An exception that can occur when parsing JSON -- -- @since 2.1.10 data JSONException = JSONParseException H.Request (H.Response ()) C.ParseError | JSONConversionException H.Request (H.Response Value) String deriving (Show, Typeable) instance Exception JSONException -- | Perform an HTTP request and consume the body with the given 'C.Sink' -- -- @since 2.1.10 httpSink :: MonadUnliftIO m => H.Request -> (H.Response () -> ConduitM S.ByteString Void m a) -> m a httpSink req sink = withRunInIO $ \run -> do man <- H.getGlobalManager E.bracket (H.responseOpen req man) H.responseClose $ \res -> run $ runConduit $ bodyReaderSource (getResponseBody res) .| sink (fmap (const ()) res) -- | Perform an HTTP request, and get the response body as a Source. -- -- The second argument to this function tells us how to make the -- Source from the Response itself. This allows you to perform actions -- with the status or headers, for example, in addition to the raw -- bytes themselves. If you just care about the response body, you can -- use 'getResponseBody' as the second argument here. -- -- @ -- \{\-# LANGUAGE OverloadedStrings \#\-} -- import Control.Monad.IO.Class (liftIO) -- import Control.Monad.Trans.Resource (runResourceT) -- import Data.Conduit (($$)) -- import qualified Data.Conduit.Binary as CB -- import qualified Data.Conduit.List as CL -- import Network.HTTP.Simple -- import System.IO (stdout) -- -- main :: IO () -- main = -- runResourceT -- $ httpSource "http://httpbin.org/robots.txt" getSrc -- $$ CB.sinkHandle stdout -- where -- getSrc res = do -- liftIO $ print (getResponseStatus res, getResponseHeaders res) -- getResponseBody res -- @ -- -- @since 2.2.1 httpSource :: (MonadResource m, MonadIO n) => H.Request -> (H.Response (C.ConduitM i S.ByteString n ()) -> C.ConduitM i o m r) -> C.ConduitM i o m r httpSource req withRes = do man <- liftIO H.getGlobalManager C.bracketP (H.responseOpen req man) H.responseClose (withRes . fmap bodyReaderSource) -- | Perform an action with the given request. This employes the -- bracket pattern. -- -- This is similar to 'httpSource', but does not require -- 'MonadResource' and allows the result to not contain a 'C.ConduitM' -- value. -- -- @since 2.2.3 withResponse :: (MonadUnliftIO m, MonadIO n) => H.Request -> (H.Response (C.ConduitM i S.ByteString n ()) -> m a) -> m a withResponse req withRes = withRunInIO $ \run -> do man <- H.getGlobalManager E.bracket (H.responseOpen req man) H.responseClose (run . withRes . fmap bodyReaderSource) -- | Same as 'parseRequest', except will throw an 'HttpException' in the -- event of a non-2XX response. This uses 'throwErrorStatusCodes' to -- implement 'checkResponse'. -- -- Exactly the same as 'parseUrlThrow', but has a name that is more -- consistent with the other parseRequest functions. -- -- @since 2.3.2 parseRequestThrow :: MonadThrow m => String -> m HC.Request parseRequestThrow = HC.parseUrlThrow -- | Same as 'parseRequestThrow', but parse errors cause an impure -- exception. Mostly useful for static strings which are known to be -- correctly formatted. -- -- @since 2.3.2 parseRequestThrow_ :: String -> HC.Request parseRequestThrow_ = either throw id . HC.parseUrlThrow -- | Alternate spelling of 'httpLBS' -- -- @since 2.1.10 httpLbs :: MonadIO m => H.Request -> m (H.Response L.ByteString) httpLbs = httpLBS -- | Set the request method -- -- @since 2.1.10 setRequestMethod :: S.ByteString -> H.Request -> H.Request setRequestMethod x req = req { H.method = x } -- | Set whether this is a secure/HTTPS (@True@) or insecure/HTTP -- (@False@) request -- -- @since 2.1.10 setRequestSecure :: Bool -> H.Request -> H.Request setRequestSecure x req = req { H.secure = x } -- | Set the destination host of the request -- -- @since 2.1.10 setRequestHost :: S.ByteString -> H.Request -> H.Request setRequestHost x r = r { H.host = x } -- | Set the destination port of the request -- -- @since 2.1.10 setRequestPort :: Int -> H.Request -> H.Request setRequestPort x r = r { H.port = x } -- | Lens for the requested path info of the request -- -- @since 2.1.10 setRequestPath :: S.ByteString -> H.Request -> H.Request setRequestPath x r = r { H.path = x } -- | Add a request header name/value combination -- -- @since 2.1.10 addRequestHeader :: H.HeaderName -> S.ByteString -> H.Request -> H.Request addRequestHeader name val req = req { H.requestHeaders = (name, val) : H.requestHeaders req } -- | Get all request header values for the given name -- -- @since 2.1.10 getRequestHeader :: H.HeaderName -> H.Request -> [S.ByteString] getRequestHeader name = map snd . filter (\(x, _) -> x == name) . H.requestHeaders -- | Set the given request header to the given list of values. Removes any -- previously set header values with the same name. -- -- @since 2.1.10 setRequestHeader :: H.HeaderName -> [S.ByteString] -> H.Request -> H.Request setRequestHeader name vals req = req { H.requestHeaders = filter (\(x, _) -> x /= name) (H.requestHeaders req) ++ (map (name, ) vals) } -- | Set the request headers, wiping out __all__ previously set headers. This -- means if you use 'setRequestHeaders' to set some headers and also use one of -- the other setters that modifies the @content-type@ header (such as -- 'setRequestBodyJSON'), be sure that 'setRequestHeaders' is evaluated -- __first__. -- -- @since 2.1.10 setRequestHeaders :: H.RequestHeaders -> H.Request -> H.Request setRequestHeaders x req = req { H.requestHeaders = x } -- | Get the query string parameters -- -- @since 2.1.10 getRequestQueryString :: H.Request -> H.Query getRequestQueryString = H.parseQuery . H.queryString -- | Set the query string parameters -- -- @since 2.1.10 setRequestQueryString :: H.Query -> H.Request -> H.Request setRequestQueryString = H.setQueryString -- | Add to the existing query string parameters. -- -- @since 2.3.5 addToRequestQueryString :: H.Query -> H.Request -> H.Request addToRequestQueryString additions req = setRequestQueryString q req where q = additions <> getRequestQueryString req -- | Set the request body to the given 'H.RequestBody'. You may want to -- consider using one of the convenience functions in the modules, e.g. -- 'requestBodyJSON'. -- -- /Note/: This will not modify the request method. For that, please use -- 'requestMethod'. You likely don't want the default of @GET@. -- -- @since 2.1.10 setRequestBody :: H.RequestBody -> H.Request -> H.Request setRequestBody x req = req { H.requestBody = x } -- | Set the request body as a JSON value -- -- /Note/: This will not modify the request method. For that, please use -- 'requestMethod'. You likely don't want the default of @GET@. -- -- This also sets the @Content-Type@ to @application/json; charset=utf-8@ -- -- @since 2.1.10 setRequestBodyJSON :: A.ToJSON a => a -> H.Request -> H.Request setRequestBodyJSON x req = req { H.requestHeaders = (H.hContentType, "application/json; charset=utf-8") : filter (\(y, _) -> y /= H.hContentType) (H.requestHeaders req) , H.requestBody = H.RequestBodyLBS $ A.encode x } -- | Set the request body as a lazy @ByteString@ -- -- /Note/: This will not modify the request method. For that, please use -- 'requestMethod'. You likely don't want the default of @GET@. -- -- @since 2.1.10 setRequestBodyLBS :: L.ByteString -> H.Request -> H.Request setRequestBodyLBS = setRequestBody . H.RequestBodyLBS -- | Set the request body as a 'C.Source' -- -- /Note/: This will not modify the request method. For that, please use -- 'requestMethod'. You likely don't want the default of @GET@. -- -- @since 2.1.10 setRequestBodySource :: Int64 -- ^ length of source -> ConduitM () S.ByteString IO () -> H.Request -> H.Request setRequestBodySource len src req = req { H.requestBody = HC.requestBodySource len src } -- | Set the request body as a file -- -- /Note/: This will not modify the request method. For that, please use -- 'requestMethod'. You likely don't want the default of @GET@. -- -- @since 2.1.10 setRequestBodyFile :: FilePath -> H.Request -> H.Request setRequestBodyFile = setRequestBody . HI.RequestBodyIO . H.streamFile -- | Set the request body as URL encoded data -- -- /Note/: This will change the request method to @POST@ and set the @content-type@ -- to @application/x-www-form-urlencoded@ -- -- @since 2.1.10 setRequestBodyURLEncoded :: [(S.ByteString, S.ByteString)] -> H.Request -> H.Request setRequestBodyURLEncoded = H.urlEncodedBody -- | Set basic auth with the given username and password -- -- @since 2.1.10 setRequestBasicAuth :: S.ByteString -- ^ username -> S.ByteString -- ^ password -> H.Request -> H.Request setRequestBasicAuth = H.applyBasicAuth -- | Instead of using the default global 'H.Manager', use the supplied -- @Manager@. -- -- @since 2.1.10 setRequestManager :: H.Manager -> H.Request -> H.Request setRequestManager x req = req { HI.requestManagerOverride = Just x } -- | Override the default proxy server settings -- -- @since 2.1.10 setRequestProxy :: Maybe H.Proxy -> H.Request -> H.Request setRequestProxy x req = req { H.proxy = x } -- | Get the status of the response -- -- @since 2.1.10 getResponseStatus :: H.Response a -> H.Status getResponseStatus = H.responseStatus -- | Get the integral status code of the response -- -- @since 2.1.10 getResponseStatusCode :: H.Response a -> Int getResponseStatusCode = H.statusCode . getResponseStatus -- | Get all response header values with the given name -- -- @since 2.1.10 getResponseHeader :: H.HeaderName -> H.Response a -> [S.ByteString] getResponseHeader name = map snd . filter (\(x, _) -> x == name) . H.responseHeaders -- | Get all response headers -- -- @since 2.1.10 getResponseHeaders :: H.Response a -> [(H.HeaderName, S.ByteString)] getResponseHeaders = H.responseHeaders -- | Get the response body -- -- @since 2.1.10 getResponseBody :: H.Response a -> a getResponseBody = H.responseBody http-conduit-2.3.7.1/test/main.hs0000644000000000000000000006761413462041647014756 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} import Test.Hspec import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy.Char8 as L8 import Test.HUnit import Network.Wai hiding (requestBody) import Network.Wai.Conduit (responseSource, sourceRequestBody) import Network.HTTP.Client (streamFile) import System.IO.Temp (withSystemTempFile) import qualified Network.Wai as Wai import Network.Wai.Handler.Warp (runSettings, defaultSettings, setPort, setBeforeMainLoop, Settings, setTimeout) import Network.HTTP.Conduit hiding (port) import qualified Network.HTTP.Conduit as NHC import Network.HTTP.Client.MultipartFormData import Control.Concurrent (forkIO, killThread, putMVar, takeMVar, newEmptyMVar, threadDelay) import Network.HTTP.Types import UnliftIO.Exception (try, SomeException, bracket, onException, IOException) import qualified Data.IORef as I import qualified Control.Exception as E (catch) import qualified Network.Socket as NS import qualified Network.BSD import CookieTest (cookieTest) #if MIN_VERSION_conduit(1,1,0) import Data.Conduit.Network (runTCPServer, serverSettings, appSink, appSource, ServerSettings) import Data.Streaming.Network (bindPortTCP, setAfterBind) #define bindPort bindPortTCP #else import Data.Conduit.Network (runTCPServer, serverSettings, HostPreference (..), appSink, appSource, bindPort, serverAfterBind, ServerSettings) #endif import qualified Data.Conduit.Network import System.IO.Unsafe (unsafePerformIO) import Data.Conduit ((.|), yield, Flush (Chunk, Flush), await, runConduit) import Control.Monad (void, forever) import Control.Monad.IO.Class (liftIO) import Data.ByteString.UTF8 (fromString) import Data.Conduit.List (sourceList) import Data.CaseInsensitive (mk) import Data.List (partition) import qualified Data.Conduit.List as CL import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified Data.ByteString.Lazy as L import Blaze.ByteString.Builder (fromByteString) import System.IO import Data.Time.Clock import Data.Time.Calendar import qualified Network.Wai.Handler.WarpTLS as WT import Network.Connection (settingDisableCertificateValidation) import Data.Default.Class (def) import qualified Data.Aeson as A import qualified Network.HTTP.Simple as Simple import Data.Monoid (mempty) import Control.Monad.Trans.Resource (runResourceT) past :: UTCTime past = UTCTime (ModifiedJulianDay 56200) (secondsToDiffTime 0) future :: UTCTime future = UTCTime (ModifiedJulianDay 562000) (secondsToDiffTime 0) cookie :: Cookie cookie = Cookie { cookie_name = "key" , cookie_value = "value" , cookie_expiry_time = future , cookie_domain = "127.0.0.1" , cookie_path = "/dump_cookies" , cookie_creation_time = past , cookie_last_access_time = past , cookie_persistent = False , cookie_host_only = False , cookie_secure_only = False , cookie_http_only = False } cookie_jar :: CookieJar cookie_jar = createCookieJar [cookie] app :: Wai.Request -> IO Wai.Response app req = case pathInfo req of [] -> if maybe False ("example.com:" `S.isPrefixOf`) $ lookup "host" $ Wai.requestHeaders req then return $ responseLBS status200 [] "homepage for example.com" else return $ responseLBS status200 [] "homepage" ["cookies"] -> return $ responseLBS status200 [tastyCookie] "cookies" ["cookie_redir1"] -> return $ responseLBS status303 [tastyCookie, (hLocation, "/checkcookie")] "" ["checkcookie"] -> return $ case lookup hCookie $ Wai.requestHeaders req of Just "flavor=chocolate-chip" -> responseLBS status200 [] "nom-nom-nom" _ -> responseLBS status412 [] "Baaaw where's my chocolate?" ["infredir", i'] -> let i = read $ T.unpack i' :: Int in return $ responseLBS status303 [(hLocation, S.append "/infredir/" $ S8.pack $ show $ i+1)] (L8.pack $ show i) ["dump_cookies"] -> return $ responseLBS status200 [] $ L.fromChunks $ return $ maybe "" id $ lookup hCookie $ Wai.requestHeaders req ["delayed"] -> return $ responseSource status200 [("foo", "bar")] $ do yield Flush liftIO $ threadDelay 30000000 yield $ Chunk $ fromByteString "Hello World!" _ -> return $ responseLBS status404 [] "not found" where tastyCookie = (mk (fromString "Set-Cookie"), fromString "flavor=chocolate-chip;") nextPort :: I.IORef Int nextPort = unsafePerformIO $ I.newIORef 15452 {-# NOINLINE nextPort #-} getPort :: IO Int getPort = do port <- I.atomicModifyIORef nextPort $ \p -> (p + 1, p + 1) esocket <- try $ bindPort port "*4" case esocket of Left (_ :: IOException) -> getPort Right socket -> do NS.close socket return port withApp :: (Wai.Request -> IO Wai.Response) -> (Int -> IO ()) -> IO () withApp app' f = withApp' (const app') f withApp' :: (Int -> Wai.Request -> IO Wai.Response) -> (Int -> IO ()) -> IO () withApp' = withAppSettings id withAppSettings :: (Settings -> Settings) -> (Int -> Wai.Request -> IO Wai.Response) -> (Int -> IO ()) -> IO () withAppSettings modSettings app' f = do port <- getPort baton <- newEmptyMVar bracket (forkIO $ runSettings (modSettings $ setPort port $ setBeforeMainLoop (putMVar baton ()) defaultSettings) (app'' port) `onException` putMVar baton ()) killThread (const $ takeMVar baton >> f port) where app'' port req sendResponse = do res <- app' port req sendResponse res withAppTls :: (Wai.Request -> IO Wai.Response) -> (Int -> IO ()) -> IO () withAppTls app' f = withAppTls' (const app') f withAppTls' :: (Int -> Wai.Request -> IO Wai.Response) -> (Int -> IO ()) -> IO () withAppTls' app' f = do port <- getPort baton <- newEmptyMVar bracket (forkIO $ WT.runTLS WT.defaultTlsSettings ( setPort port $ setBeforeMainLoop (putMVar baton ()) defaultSettings) (app'' port) `onException` putMVar baton ()) killThread (const $ takeMVar baton >> f port) where app'' port req sendResponse = do res <- app' port req sendResponse res main :: IO () main = do mapM_ (`hSetBuffering` LineBuffering) [stdout, stderr] hspec $ do cookieTest describe "simpleHttp" $ do it "gets homepage" $ withApp app $ \port -> do lbs <- simpleHttp $ "http://127.0.0.1:" ++ show port lbs @?= "homepage" it "throws exception on 404" $ withApp app $ \port -> do elbs <- try $ simpleHttp $ concat ["http://127.0.0.1:", show port, "/404"] case elbs of Left (HttpExceptionRequest _ StatusCodeException {}) -> return () _ -> error "Expected an exception" describe "httpLbs" $ do it "preserves 'set-cookie' headers" $ withApp app $ \port -> do request <- parseUrlThrow $ concat ["http://127.0.0.1:", show port, "/cookies"] manager <- newManager tlsManagerSettings response <- httpLbs request manager let setCookie = mk (fromString "Set-Cookie") (setCookieHeaders, _) = partition ((== setCookie) . fst) (NHC.responseHeaders response) assertBool "response contains a 'set-cookie' header" $ length setCookieHeaders > 0 it "redirects set cookies" $ withApp app $ \port -> do request <- parseUrlThrow $ concat ["http://127.0.0.1:", show port, "/cookie_redir1"] manager <- newManager tlsManagerSettings response <- httpLbs request manager (responseBody response) @?= "nom-nom-nom" it "user-defined cookie jar works" $ withApp app $ \port -> do request <- parseUrlThrow $ concat ["http://127.0.0.1:", show port, "/dump_cookies"] manager <- newManager tlsManagerSettings response <- httpLbs (request {redirectCount = 1, cookieJar = Just cookie_jar}) manager (responseBody response) @?= "key=value" it "user-defined cookie jar is not ignored when redirection is disabled" $ withApp app $ \port -> do request <- parseUrlThrow $ concat ["http://127.0.0.1:", show port, "/dump_cookies"] manager <- newManager tlsManagerSettings response <- httpLbs (request {redirectCount = 0, cookieJar = Just cookie_jar}) manager (responseBody response) @?= "key=value" it "cookie jar is available in response" $ withApp app $ \port -> do request <- parseUrlThrow $ concat ["http://127.0.0.1:", show port, "/cookies"] manager <- newManager tlsManagerSettings response <- httpLbs (request {cookieJar = Just Data.Monoid.mempty}) manager (length $ destroyCookieJar $ responseCookieJar response) @?= 1 it "Cookie header isn't touched when no cookie jar supplied" $ withApp app $ \port -> do request <- parseUrlThrow $ concat ["http://127.0.0.1:", show port, "/dump_cookies"] manager <- newManager tlsManagerSettings let request_headers = (mk "Cookie", "key2=value2") : filter ((/= mk "Cookie") . fst) (NHC.requestHeaders request) response <- httpLbs (request {NHC.requestHeaders = request_headers, cookieJar = Nothing}) manager (responseBody response) @?= "key2=value2" it "Response cookie jar is nothing when request cookie jar is nothing" $ withApp app $ \port -> do request <- parseUrlThrow $ concat ["http://127.0.0.1:", show port, "/cookies"] manager <- newManager tlsManagerSettings response <- httpLbs (request {cookieJar = Nothing}) manager (responseCookieJar response) @?= mempty it "TLS" $ withAppTls app $ \port -> do request <- parseUrlThrow $ "https://127.0.0.1:" ++ show port let set = mkManagerSettings def { settingDisableCertificateValidation = True } Nothing manager <- newManager set response <- httpLbs request manager responseBody response @?= "homepage" describe "manager" $ do it "closes all connections" $ withApp app $ \port1 -> withApp app $ \port2 -> do --FIXME clearSocketsList manager <- newManager tlsManagerSettings let Just req1 = parseUrlThrow $ "http://127.0.0.1:" ++ show port1 let Just req2 = parseUrlThrow $ "http://127.0.0.1:" ++ show port2 runResourceT $ do _res1a <- http req1 manager _res1b <- http req1 manager _res2 <- http req2 manager return () --FIXME requireAllSocketsClosed describe "http" $ do it "response body" $ withApp app $ \port -> do manager <- newManager tlsManagerSettings req <- parseUrlThrow $ "http://127.0.0.1:" ++ show port runResourceT $ do res1 <- http req manager bss <- runConduit $ responseBody res1 .| CL.consume res2 <- httpLbs req manager liftIO $ L.fromChunks bss `shouldBe` responseBody res2 describe "DOS protection" $ do it "overlong headers" $ overLongHeaders $ \port -> do manager <- newManager tlsManagerSettings let Just req1 = parseUrlThrow $ "http://127.0.0.1:" ++ show port res1 <- try $ runResourceT $ http req1 manager case res1 of Left e -> show (e :: SomeException) @?= show (HttpExceptionRequest req1 OverlongHeaders) _ -> error "Shouldn't have worked" it "not overlong headers" $ notOverLongHeaders $ \port -> do manager <- newManager tlsManagerSettings let Just req1 = parseUrlThrow $ "http://127.0.0.1:" ++ show port _ <- httpLbs req1 manager return () describe "redirects" $ do it "doesn't double escape" $ redir $ \port -> do manager <- newManager tlsManagerSettings let go (encoded, final) = do let Just req1 = parseUrlThrow $ concat ["http://127.0.0.1:", show port, "/redir/", encoded] res <- httpLbs req1 manager liftIO $ Network.HTTP.Conduit.responseStatus res @?= status200 liftIO $ responseBody res @?= L.fromChunks [TE.encodeUtf8 final] mapM_ go [ ("hello world%2F", "hello world/") , ("%D7%A9%D7%9C%D7%95%D7%9D", "שלום") , ("simple", "simple") , ("hello%20world", "hello world") , ("hello%20world%3f%23", "hello world?#") ] it "TooManyRedirects: redirect request body is preserved" $ withApp app $ \port -> do let Just req = parseUrlThrow $ concat ["http://127.0.0.1:", show port, "/infredir/0"] let go (res, i) = liftIO $ responseBody res @?= (L8.pack $ show i) manager <- newManager tlsManagerSettings E.catch (void $ runResourceT $ http req{redirectCount=5} manager) $ \e -> case e of HttpExceptionRequest _ (TooManyRedirects redirs) -> mapM_ go (zip redirs [5,4..0 :: Int]) _ -> error $ show e describe "chunked request body" $ do it "works" $ echo $ \port -> do manager <- newManager tlsManagerSettings let go bss = do let Just req1 = parseUrlThrow $ "POST http://127.0.0.1:" ++ show port src = sourceList bss lbs = L.fromChunks bss res <- httpLbs req1 { requestBody = requestBodySourceChunked src } manager liftIO $ Network.HTTP.Conduit.responseStatus res @?= status200 let ts = S.concat . L.toChunks liftIO $ ts (responseBody res) @?= ts lbs mapM_ go [ ["hello", "world"] , replicate 500 "foo\003\n\r" ] describe "no status message" $ do it "works" $ noStatusMessage $ \port -> do req <- parseUrlThrow $ "http://127.0.0.1:" ++ show port manager <- newManager tlsManagerSettings res <- httpLbs req manager liftIO $ do Network.HTTP.Conduit.responseStatus res `shouldBe` status200 responseBody res `shouldBe` "foo" describe "response body too short" $ do it "throws an exception" $ wrongLength $ \port -> do req <- parseUrlThrow $ "http://127.0.0.1:" ++ show port manager <- newManager tlsManagerSettings eres <- try $ httpLbs req manager liftIO $ either (Left . (show :: HttpException -> String)) (Right . id) eres `shouldBe` Left (show $ HttpExceptionRequest req $ ResponseBodyTooShort 50 18) describe "chunked response body" $ do it "no chunk terminator" $ wrongLengthChunk1 $ \port -> do req <- parseUrlThrow $ "http://127.0.0.1:" ++ show port manager <- newManager tlsManagerSettings eres <- try $ httpLbs req manager liftIO $ either (Left . (show :: HttpException -> String)) (Right . id) eres `shouldBe` Left (show (HttpExceptionRequest req IncompleteHeaders)) it "incomplete chunk" $ wrongLengthChunk2 $ \port -> do req <- parseUrlThrow $ "http://127.0.0.1:" ++ show port manager <- newManager tlsManagerSettings eres <- try $ httpLbs req manager liftIO $ either (Left . (show :: HttpException -> String)) (Right . id) eres `shouldBe` Left (show (HttpExceptionRequest req InvalidChunkHeaders)) it "invalid chunk" $ invalidChunk $ \port -> do req <- parseUrlThrow $ "http://127.0.0.1:" ++ show port manager <- newManager tlsManagerSettings eres <- try $ httpLbs req manager liftIO $ either (Left . (show :: HttpException -> String)) (Right . id) eres `shouldBe` Left (show (HttpExceptionRequest req InvalidChunkHeaders)) it "missing header" $ rawApp "HTTP/1.1 200 OK\r\nTransfer-Encoding: chunked\r\n\r\n4\r\nabcd\r\n\r\n\r\n" $ \port -> do req <- parseUrlThrow $ "http://127.0.0.1:" ++ show port manager <- newManager tlsManagerSettings eres <- try $ httpLbs req manager liftIO $ either (Left . (show :: HttpException -> String)) (Right . id) eres `shouldBe` Left (show (HttpExceptionRequest req InvalidChunkHeaders)) it "junk header" $ rawApp "HTTP/1.1 200 OK\r\nTransfer-Encoding: chunked\r\n\r\n4\r\nabcd\r\njunk\r\n\r\n" $ \port -> do req <- parseUrlThrow $ "http://127.0.0.1:" ++ show port manager <- newManager tlsManagerSettings eres <- try $ httpLbs req manager liftIO $ either (Left . (show :: HttpException -> String)) (Right . id) eres `shouldBe` Left (show (HttpExceptionRequest req InvalidChunkHeaders)) describe "redirect" $ do it "ignores large response bodies" $ do let app' port req = case pathInfo req of ["foo"] -> return $ responseLBS status200 [] "Hello World!" _ -> return $ responseSource status301 [("location", S8.pack $ "http://127.0.0.1:" ++ show port ++ "/foo")] $ forever $ yield $ Chunk $ fromByteString "hello\n" manager <- newManager tlsManagerSettings withApp' app' $ \port -> do req <- liftIO $ parseUrlThrow $ "http://127.0.0.1:" ++ show port res <- httpLbs req manager liftIO $ do Network.HTTP.Conduit.responseStatus res `shouldBe` status200 responseBody res `shouldBe` "Hello World!" describe "multipart/form-data" $ do it "formats correctly" $ do let bd = "---------------------------190723902820679116301912680260" (RequestBodyStream _ givesPopper) <- renderParts bd [partBS "email" "" ,partBS "parent_id" "70488" ,partBS "captcha" "" ,partBS "homeboard" "0chan.hk" ,partBS "text" $ TE.encodeUtf8 ">>72127\r\nМы работаем над этим." ,partFileSource "upload" "nyan.gif" ] ires <- I.newIORef S.empty let loop front popper = do bs <- popper if S.null bs then I.writeIORef ires $ S.concat $ front [] else loop (front . (bs:)) popper givesPopper $ loop id mfd <- I.readIORef ires exam <- S.readFile "multipart-example.bin" mfd @?= exam describe "HTTP/1.0" $ do it "BaseHTTP" $ do let baseHTTP app' = do _ <- runConduit $ appSource app' .| await runConduit $ yield "HTTP/1.0 200 OK\r\n\r\nThis is it!" .| appSink app' manager <- newManager tlsManagerSettings withCApp baseHTTP $ \port -> do req <- liftIO $ parseUrlThrow $ "http://127.0.0.1:" ++ show port res1 <- httpLbs req manager res2 <- httpLbs req manager liftIO $ res1 @?= res2 describe "hostAddress" $ do it "overrides host" $ withApp app $ \port -> do entry <- Network.BSD.getHostByName "127.0.0.1" req' <- parseUrlThrow $ "http://example.com:" ++ show port let req = req' { hostAddress = Just $ Network.BSD.hostAddress entry } manager <- newManager tlsManagerSettings res <- httpLbs req manager responseBody res @?= "homepage for example.com" describe "managerResponseTimeout" $ do it "works" $ withApp app $ \port -> do req1 <- parseUrlThrow $ "http://localhost:" ++ show port let req2 = req1 { responseTimeout = responseTimeoutMicro 5000000 } man <- newManager tlsManagerSettings { managerResponseTimeout = responseTimeoutMicro 1 } eres1 <- try $ httpLbs req1 { NHC.path = "/delayed" } man case eres1 of Left (HttpExceptionRequest _ ConnectionTimeout{}) -> return () _ -> error "Did not time out" _ <- httpLbs req2 man return () describe "delayed body" $ do it "works" $ withApp app $ \port -> do req <- parseUrlThrow $ "http://localhost:" ++ show port ++ "/delayed" man <- newManager tlsManagerSettings _ <- runResourceT $ http req man return () it "reuse/connection close tries again" $ do withAppSettings (setTimeout 1) (const app) $ \port -> do req <- parseUrlThrow $ "http://localhost:" ++ show port man <- newManager tlsManagerSettings res1 <- httpLbs req man threadDelay 3000000 res2 <- httpLbs req man let f res = res { NHC.responseHeaders = filter (not . isDate) (NHC.responseHeaders res) } isDate ("date", _) = True isDate _ = False f res2 `shouldBe` f res1 it "setQueryString" $ do ref <- I.newIORef undefined let app' req = do I.writeIORef ref $ Wai.queryString req return $ responseLBS status200 [] "" withApp app' $ \port -> do let qs = [ ("foo", Just "bar") , (TE.encodeUtf8 "שלום", Just "hola") , ("noval", Nothing) ] man <- newManager tlsManagerSettings req <- parseUrlThrow $ "http://localhost:" ++ show port _ <- httpLbs (setQueryString qs req) man res <- I.readIORef ref res `shouldBe` qs describe "Simple.JSON" $ do it "normal" $ jsonApp $ \port -> do req <- parseUrlThrow $ "http://localhost:" ++ show port value <- Simple.httpJSON req responseBody value `shouldBe` jsonValue it "trailing whitespace" $ jsonApp $ \port -> do req <- parseUrlThrow $ "http://localhost:" ++ show port ++ "/trailing" value <- Simple.httpJSON req responseBody value `shouldBe` jsonValue it "RequestBodyIO" $ echo $ \port -> do manager <- newManager tlsManagerSettings let go bss = withSystemTempFile "request-body-io" $ \tmpfp tmph -> do liftIO $ do mapM_ (S.hPutStr tmph) bss hClose tmph let Just req1 = parseUrlThrow $ "POST http://127.0.0.1:" ++ show port lbs = L.fromChunks bss res <- httpLbs req1 { requestBody = RequestBodyIO (streamFile tmpfp) } manager liftIO $ Network.HTTP.Conduit.responseStatus res @?= status200 let ts = S.concat . L.toChunks liftIO $ ts (responseBody res) @?= ts lbs mapM_ go [ ["hello", "world"] , replicate 500 "foo\003\n\r" ] withCApp :: (Data.Conduit.Network.AppData -> IO ()) -> (Int -> IO ()) -> IO () withCApp app' f = do port <- getPort baton <- newEmptyMVar let start = putMVar baton () #if MIN_VERSION_conduit(1,1,0) settings :: ServerSettings settings = setAfterBind (const start) (serverSettings port "*") #else settings :: ServerSettings IO settings = (serverSettings port "*" :: ServerSettings IO) { serverAfterBind = const start } #endif bracket (forkIO $ runTCPServer settings app' `onException` start) killThread (const $ takeMVar baton >> f port) overLongHeaders :: (Int -> IO ()) -> IO () overLongHeaders = withCApp $ \app' -> runConduit $ src .| appSink app' where src = sourceList $ "HTTP/1.0 200 OK\r\nfoo: " : repeat "bar" notOverLongHeaders :: (Int -> IO ()) -> IO () notOverLongHeaders = withCApp $ \app' -> do runConduit $ appSource app' .| CL.drop 1 runConduit $ src .| appSink app' where src = sourceList $ [S.concat $ "HTTP/1.0 200 OK\r\nContent-Type: text/plain\r\nContent-Length: 16384\r\n\r\n" : ( take 16384 $ repeat "x")] redir :: (Int -> IO ()) -> IO () redir = withApp' redirApp where redirApp port req = case pathInfo req of ["redir", foo] -> return $ responseLBS status301 [ ("Location", S8.pack (concat ["http://127.0.0.1:", show port, "/content/"]) `S.append` escape foo) ] "" ["content", foo] -> return $ responseLBS status200 [] $ L.fromChunks [TE.encodeUtf8 foo] _ -> return $ responseLBS status404 [] "" escape = S8.concatMap (S8.pack . encodeUrlChar) . TE.encodeUtf8 encodeUrlChar :: Char -> String encodeUrlChar c -- List of unreserved characters per RFC 3986 -- Gleaned from http://en.wikipedia.org/wiki/Percent-encoding | 'A' <= c && c <= 'Z' = [c] | 'a' <= c && c <= 'z' = [c] | '0' <= c && c <= '9' = [c] encodeUrlChar c@'-' = [c] encodeUrlChar c@'_' = [c] encodeUrlChar c@'.' = [c] encodeUrlChar c@'~' = [c] encodeUrlChar y = let (a, c) = fromEnum y `divMod` 16 b = a `mod` 16 showHex' x | x < 10 = toEnum $ x + (fromEnum '0') | x < 16 = toEnum $ x - 10 + (fromEnum 'A') | otherwise = error $ "Invalid argument to showHex: " ++ show x in ['%', showHex' b, showHex' c] echo :: (Int -> IO ()) -> IO () echo = withApp $ \req -> do bss <- runConduit $ sourceRequestBody req .| CL.consume return $ responseLBS status200 [] $ L.fromChunks bss noStatusMessage :: (Int -> IO ()) -> IO () noStatusMessage = withCApp $ \app' -> runConduit $ src .| appSink app' where src = yield "HTTP/1.0 200\r\nContent-Length: 3\r\n\r\nfoo: barbazbin" wrongLength :: (Int -> IO ()) -> IO () wrongLength = withCApp $ \app' -> do _ <- runConduit $ appSource app' .| await runConduit $ src .| appSink app' where src = do yield "HTTP/1.0 200 OK\r\nContent-Length: 50\r\n\r\n" yield "Not quite 50 bytes" wrongLengthChunk1 :: (Int -> IO ()) -> IO () wrongLengthChunk1 = withCApp $ \app' -> do _ <- runConduit $ appSource app' .| await runConduit $ src .| appSink app' where src = yield "HTTP/1.1 200 OK\r\nTransfer-Encoding: chunked\r\n\r\n4\r\nWiki\r\n" wrongLengthChunk2 :: (Int -> IO ()) -> IO () wrongLengthChunk2 = withCApp $ \app' -> do _ <- runConduit $ appSource app' .| await runConduit $ src .| appSink app' where src = yield "HTTP/1.1 200 OK\r\nTransfer-Encoding: chunked\r\n\r\n4\r\nWiki\r\n5\r\npedia\r\nE\r\nin\r\n\r\nch\r\n" invalidChunk :: (Int -> IO ()) -> IO () invalidChunk = withCApp $ \app' -> do _ <- runConduit $ appSource app' .| await runConduit $ src .| appSink app' where src = yield "HTTP/1.1 200 OK\r\nTransfer-Encoding: chunked\r\n\r\n4\r\nabcd\r\ngarbage\r\nef\r\n0\r\n\r\n" rawApp :: S8.ByteString -> (Int -> IO ()) -> IO () rawApp bs = withCApp $ \app' -> do _ <- runConduit $ appSource app' .| await runConduit $ src .| appSink app' where src = yield bs jsonApp :: (Int -> IO ()) -> IO () jsonApp = withApp $ \req -> return $ responseLBS status200 [ ("Content-Type", "application/json") ] $ case pathInfo req of [] -> A.encode jsonValue ["trailing"] -> A.encode jsonValue <> " \n\r\n\t " x -> error $ "unsupported: " ++ show x jsonValue :: A.Value jsonValue = A.object [ "name" A..= ("Alice" :: String) , "age" A..= (35 :: Int) ] http-conduit-2.3.7.1/test/CookieTest.hs0000644000000000000000000007750313316025440016070 0ustar0000000000000000module CookieTest (cookieTest) where import Prelude hiding (exp) import Test.Hspec import qualified Data.ByteString as BS import Test.HUnit hiding (path) import Network.HTTP.Client import qualified Network.HTTP.Conduit as HC import Data.ByteString.UTF8 import Data.Monoid import Data.Time.Clock import Data.Time.Calendar import qualified Data.CaseInsensitive as CI import Web.Cookie default_request :: HC.Request default_request = HC.parseRequest_ "http://www.google.com/" default_cookie :: Cookie default_cookie = Cookie { cookie_name = fromString "name" , cookie_value = fromString "value" , cookie_expiry_time = default_time , cookie_domain = fromString "www.google.com" , cookie_path = fromString "/" , cookie_creation_time = default_time , cookie_last_access_time = default_time , cookie_persistent = False , cookie_host_only = False , cookie_secure_only = False , cookie_http_only = False } default_time :: UTCTime default_time = UTCTime (ModifiedJulianDay 56200) (secondsToDiffTime 0) default_diff_time :: DiffTime default_diff_time = secondsToDiffTime 1209600 default_set_cookie :: SetCookie default_set_cookie = def { setCookieName = fromString "name" , setCookieValue = fromString "value" , setCookiePath = Just $ fromString "/" , setCookieExpires = Just default_time , setCookieMaxAge = Just default_diff_time , setCookieDomain = Just $ fromString "www.google.com" , setCookieHttpOnly = False , setCookieSecure = False } testValidIp :: IO () testValidIp = assertBool "Couldn't parse valid IP address" $ isIpAddress $ fromString "1.2.3.4" testIpNumTooHigh :: IO () testIpNumTooHigh = assertBool "One of the digits in the IP address is too large" $ not $ isIpAddress $ fromString "501.2.3.4" testTooManySegmentsInIp :: IO () testTooManySegmentsInIp = assertBool "Too many segments in the ip address" $ not $ isIpAddress $ fromString "1.2.3.4.5" testCharsInIp :: IO () testCharsInIp = assertBool "Chars are not allowed in IP addresses" $ not $ isIpAddress $ fromString "1.2a3.4.5" testDomainMatchesSuccess :: IO () testDomainMatchesSuccess = assertBool "Domains should match" $ domainMatches (fromString "www.google.com") (fromString "google.com") testSameDomain :: IO () testSameDomain = assertBool "Same domain should match" $ domainMatches domain domain where domain = fromString "www.google.com" testSiblingDomain :: IO () testSiblingDomain = assertBool "Sibling domain should not match" $ not $ domainMatches (fromString "www.google.com") (fromString "secure.google.com") testParentDomain :: IO () testParentDomain = assertBool "Parent domain should fail" $ not $ domainMatches (fromString "google.com") (fromString "www.google.com") testNaiveSuffixDomain :: IO () testNaiveSuffixDomain = assertBool "Naively checking for suffix for domain matching should fail" $ not $ domainMatches (fromString "agoogle.com") (fromString "google.com") testDefaultPath :: IO () testDefaultPath = assertEqual "Getting default path from a request" (fromString "/") (defaultPath default_request) testShortDefaultPath :: IO () testShortDefaultPath = assertEqual "Getting default path from a short path" (fromString "/") (defaultPath $ default_request {HC.path = fromString "/search"}) testPopulatedDefaultPath :: IO () testPopulatedDefaultPath = assertEqual "Getting default path from a request with a path" (fromString "/search") (defaultPath $ default_request {HC.path = fromString "/search/term"}) testParamsDefaultPath :: IO () testParamsDefaultPath = assertEqual "Getting default path from a request with a path and GET params" (fromString "/search") (defaultPath $ default_request {HC.path = fromString "/search/term?var=val"}) testDefaultPathEndingInSlash :: IO () testDefaultPathEndingInSlash = assertEqual "Getting default path that ends in a slash" (fromString "/search/term") (defaultPath $ default_request {HC.path = fromString "/search/term/"}) testSamePathsMatch :: IO () testSamePathsMatch = assertBool "The same path should match" $ pathMatches path' path' where path' = fromString "/a/path" testPathSlashAtEnd :: IO () testPathSlashAtEnd = assertBool "Putting the slash at the end should still match paths" $ pathMatches (fromString "/a/path/to/here") (fromString "/a/path/") testPathNoSlashAtEnd :: IO () testPathNoSlashAtEnd = assertBool "Not putting the slash at the end should still match paths" $ pathMatches (fromString "/a/path/to/here") (fromString "/a/path") testDivergingPaths :: IO () testDivergingPaths = assertBool "Diverging paths don't match" $ not $ pathMatches (fromString "/a/path/to/here") (fromString "/a/different/path") testCookieEqualitySuccess :: IO () testCookieEqualitySuccess = assertEqual "The same cookies should be equal" cookie cookie where cookie = default_cookie testCookieEqualityResiliance :: IO () testCookieEqualityResiliance = assertEqual "Cookies should still be equal if extra options are changed" (default_cookie {cookie_persistent = True}) (default_cookie {cookie_host_only = True}) testDomainChangesEquality :: IO () testDomainChangesEquality = assertBool "Changing the domain should make cookies not equal" $ default_cookie /= (default_cookie {cookie_domain = fromString "/search"}) testRemoveCookie :: IO () testRemoveCookie = assertEqual "Removing a cookie works" (Just default_cookie, createCookieJar []) (removeExistingCookieFromCookieJar default_cookie $ createCookieJar [default_cookie]) testRemoveNonexistantCookie :: IO () testRemoveNonexistantCookie = assertEqual "Removing a nonexistent cookie doesn't work" (Nothing, createCookieJar [default_cookie]) (removeExistingCookieFromCookieJar (default_cookie {cookie_name = fromString "key2"}) $ createCookieJar [default_cookie]) testRemoveCorrectCookie :: IO () testRemoveCorrectCookie = assertEqual "Removing only the correct cookie" (Just search_for, createCookieJar [red_herring]) (removeExistingCookieFromCookieJar search_for $ createCookieJar [red_herring, search_for]) where search_for = default_cookie {cookie_name = fromString "name1"} red_herring = default_cookie {cookie_name = fromString "name2"} testEvictExpiredCookies :: IO () testEvictExpiredCookies = assertEqual "Evicting expired cookies works" (createCookieJar [a, c]) (evictExpiredCookies (createCookieJar [a, b, c, d]) middle) where a = default_cookie { cookie_name = fromString "a" , cookie_expiry_time = UTCTime (ModifiedJulianDay 3) (secondsToDiffTime 0) } b = default_cookie { cookie_name = fromString "b" , cookie_expiry_time = UTCTime (ModifiedJulianDay 1) (secondsToDiffTime 0) } c = default_cookie { cookie_name = fromString "c" , cookie_expiry_time = UTCTime (ModifiedJulianDay 3) (secondsToDiffTime 0) } d = default_cookie { cookie_name = fromString "d" , cookie_expiry_time = UTCTime (ModifiedJulianDay 1) (secondsToDiffTime 0) } middle = UTCTime (ModifiedJulianDay 2) (secondsToDiffTime 0) testEvictNoCookies :: IO () testEvictNoCookies = assertEqual "Evicting empty cookie jar" (createCookieJar []) (evictExpiredCookies (createCookieJar []) middle) where middle = UTCTime (ModifiedJulianDay 2) (secondsToDiffTime 0) testComputeCookieStringUpdateLastAccessTime :: IO () testComputeCookieStringUpdateLastAccessTime = assertEqual "Updates last access time upon using cookies" (fromString "name=value", out_cookie_jar) (computeCookieString request cookie_jar now True) where request = default_request cookie_jar = createCookieJar [default_cookie] now = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 1) out_cookie_jar = createCookieJar [default_cookie {cookie_last_access_time = now}] testComputeCookieStringHostOnly :: IO () testComputeCookieStringHostOnly = assertEqual "Host only cookies should match host exactly" (fromString "name=value", cookie_jar) (computeCookieString request cookie_jar default_time True) where request = default_request cookie_jar = createCookieJar [default_cookie {cookie_host_only = True}] testComputeCookieStringHostOnlyFilter :: IO () testComputeCookieStringHostOnlyFilter = assertEqual "Host only cookies shouldn't match subdomain" (fromString "", cookie_jar) (computeCookieString request cookie_jar default_time True) where request = default_request {HC.host = fromString "sub1.sub2.google.com"} cookie_jar = createCookieJar [default_cookie { cookie_host_only = True , cookie_domain = fromString "sub2.google.com" } ] testComputeCookieStringDomainMatching :: IO () testComputeCookieStringDomainMatching = assertEqual "Domain matching works for new requests" (fromString "name=value", cookie_jar) (computeCookieString request cookie_jar default_time True) where request = default_request {HC.host = fromString "sub1.sub2.google.com"} cookie_jar = createCookieJar [default_cookie {cookie_domain = fromString "sub2.google.com"}] testComputeCookieStringPathMatching :: IO () testComputeCookieStringPathMatching = assertEqual "Path matching works for new requests" (fromString "name=value", cookie_jar) (computeCookieString request cookie_jar default_time True) where request = default_request {HC.path = fromString "/a/path/to/nowhere"} cookie_jar = createCookieJar [default_cookie {cookie_path = fromString "/a/path"}] testComputeCookieStringPathMatchingFails :: IO () testComputeCookieStringPathMatchingFails = assertEqual "Path matching fails when it should" (fromString "", cookie_jar) (computeCookieString request cookie_jar default_time True) where request = default_request {HC.path = fromString "/a/different/path/to/nowhere"} cookie_jar = createCookieJar [default_cookie {cookie_path = fromString "/a/path"}] testComputeCookieStringPathMatchingWithParms :: IO () testComputeCookieStringPathMatchingWithParms = assertEqual "Path matching succeeds when request has GET params" (fromString "name=value", cookie_jar) (computeCookieString request cookie_jar default_time True) where request = default_request {HC.path = fromString "/a/path/to/nowhere?var=val"} cookie_jar = createCookieJar [default_cookie {cookie_path = fromString "/a/path"}] testComputeCookieStringSecure :: IO () testComputeCookieStringSecure = assertEqual "Secure flag filters properly" (fromString "", cookie_jar) (computeCookieString default_request cookie_jar default_time True) where cookie_jar = createCookieJar [default_cookie {cookie_secure_only = True}] testComputeCookieStringHttpOnly :: IO () testComputeCookieStringHttpOnly = assertEqual "http-only flag filters properly" (fromString "", cookie_jar) (computeCookieString default_request cookie_jar default_time False) where cookie_jar = createCookieJar [default_cookie {cookie_http_only = True}] testComputeCookieStringSort :: IO () testComputeCookieStringSort = assertEqual "Sorting works correctly" (fromString "c1=v1;c3=v3;c4=v4;c2=v2", cookie_jar_out) format_output where now = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 11) cookie_jar = createCookieJar [ default_cookie { cookie_name = fromString "c1" , cookie_value = fromString "v1" , cookie_path = fromString "/all/encompassing/request" } , default_cookie { cookie_name = fromString "c2" , cookie_value = fromString "v2" , cookie_path = fromString "/all" } , default_cookie { cookie_name = fromString "c3" , cookie_value = fromString "v3" , cookie_path = fromString "/all/encompassing" , cookie_creation_time = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 1) } , default_cookie { cookie_name = fromString "c4" , cookie_value = fromString "v4" , cookie_path = fromString "/all/encompassing" , cookie_creation_time = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 2) } ] cookie_jar_out = createCookieJar [ default_cookie { cookie_name = fromString "c1" , cookie_value = fromString "v1" , cookie_path = fromString "/all/encompassing/request" , cookie_last_access_time = now } , default_cookie { cookie_name = fromString "c2" , cookie_value = fromString "v2" , cookie_path = fromString "/all" , cookie_last_access_time = now } , default_cookie { cookie_name = fromString "c3" , cookie_value = fromString "v3" , cookie_path = fromString "/all/encompassing" , cookie_creation_time = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 1) , cookie_last_access_time = now } , default_cookie { cookie_name = fromString "c4" , cookie_value = fromString "v4" , cookie_path = fromString "/all/encompassing" , cookie_creation_time = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 2) , cookie_last_access_time = now } ] request = default_request {HC.path = fromString "/all/encompassing/request/path"} format_output = computeCookieString request cookie_jar default_time False testInsertCookiesIntoRequestWorks :: IO () testInsertCookiesIntoRequestWorks = assertEqual "Inserting cookies works" [(CI.mk $ fromString "Cookie", fromString "key=val")] out_headers where out_headers = HC.requestHeaders req (req, _) = insertCookiesIntoRequest req' cookie_jar default_time cookie_jar = createCookieJar [ default_cookie { cookie_name = fromString "key" , cookie_value = fromString "val" } ] req' = default_request {HC.requestHeaders = [(CI.mk $ fromString "Cookie", fromString "otherkey=otherval")]} testReceiveSetCookie :: IO () testReceiveSetCookie = assertEqual "Receiving a Set-Cookie" (createCookieJar [default_cookie]) (receiveSetCookie default_set_cookie default_request default_time True $ createCookieJar []) testReceiveSetCookieTrailingDot :: IO () testReceiveSetCookieTrailingDot = assertEqual "Receiving a Set-Cookie with a trailing domain dot" (createCookieJar []) (receiveSetCookie set_cookie default_request default_time True $ createCookieJar []) where set_cookie = default_set_cookie {setCookieDomain = Just $ fromString "www.google.com."} testReceiveSetCookieLeadingDot :: IO () testReceiveSetCookieLeadingDot = assertEqual "Receiving a Set-Cookie with a leading domain dot" (createCookieJar [default_cookie]) (receiveSetCookie set_cookie default_request default_time True $ createCookieJar []) where set_cookie = default_set_cookie {setCookieDomain = Just $ fromString ".www.google.com"} testReceiveSetCookieNoDomain :: IO () testReceiveSetCookieNoDomain = assertEqual "Receiving cookie without domain" (createCookieJar [default_cookie]) (receiveSetCookie set_cookie default_request default_time True $ createCookieJar []) where set_cookie = default_set_cookie {setCookieDomain = Nothing} testReceiveSetCookieEmptyDomain :: IO () testReceiveSetCookieEmptyDomain = assertEqual "Receiving cookie with empty domain" (createCookieJar [default_cookie]) (receiveSetCookie set_cookie default_request default_time True $ createCookieJar []) where set_cookie = default_set_cookie {setCookieDomain = Just BS.empty} -- Can't test public suffixes until that module is written testReceiveSetCookieNonMatchingDomain :: IO () testReceiveSetCookieNonMatchingDomain = assertEqual "Receiving cookie with non-matching domain" (createCookieJar []) (receiveSetCookie set_cookie default_request default_time True $ createCookieJar []) where set_cookie = default_set_cookie {setCookieDomain = Just $ fromString "www.wikipedia.org"} testReceiveSetCookieHostOnly :: IO () testReceiveSetCookieHostOnly = assertBool "Checking host-only flag gets set" $ cookie_host_only $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar [] where set_cookie = default_set_cookie {setCookieDomain = Nothing} testReceiveSetCookieHostOnlyNotSet :: IO () testReceiveSetCookieHostOnlyNotSet = assertBool "Checking host-only flag doesn't get set" $ not $ cookie_host_only $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar [] where set_cookie = default_set_cookie {setCookieDomain = Just $ fromString "google.com"} testReceiveSetCookieHttpOnly :: IO () testReceiveSetCookieHttpOnly = assertBool "Checking http-only flag gets set" $ cookie_http_only $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar [] where set_cookie = default_set_cookie {setCookieHttpOnly = True} testReceiveSetCookieHttpOnlyNotSet :: IO () testReceiveSetCookieHttpOnlyNotSet = assertBool "Checking http-only flag doesn't get set" $ not $ cookie_http_only $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar [] where set_cookie = default_set_cookie {setCookieHttpOnly = False} testReceiveSetCookieHttpOnlyDrop :: IO () testReceiveSetCookieHttpOnlyDrop = assertEqual "Checking non http request gets dropped" (createCookieJar []) (receiveSetCookie set_cookie default_request default_time False $ createCookieJar []) where set_cookie = default_set_cookie {setCookieHttpOnly = True} testReceiveSetCookieName :: IO () testReceiveSetCookieName = assertEqual "Name gets set correctly" (fromString "name") (cookie_name $ head $ destroyCookieJar $ receiveSetCookie default_set_cookie default_request default_time True $ createCookieJar []) testReceiveSetCookieValue :: IO () testReceiveSetCookieValue = assertEqual "Value gets set correctly" (fromString "value") (cookie_value $ head $ destroyCookieJar $ receiveSetCookie default_set_cookie default_request default_time True $ createCookieJar []) testReceiveSetCookieExpiry :: IO () testReceiveSetCookieExpiry = assertEqual "Expiry gets set correctly" now_plus_diff_time (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie default_set_cookie default_request default_time True $ createCookieJar []) where now_plus_diff_time = ((fromRational $ toRational default_diff_time) `addUTCTime` default_time) testReceiveSetCookieNoMaxAge :: IO () testReceiveSetCookieNoMaxAge = assertEqual "Expiry is based on the given value" default_time (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie cookie_without_max_age default_request default_time True $ createCookieJar []) where cookie_without_max_age = default_set_cookie {setCookieMaxAge = Nothing} testReceiveSetCookieNoExpiry :: IO () testReceiveSetCookieNoExpiry = assertEqual "Expiry is based on max age" now_plus_diff_time (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie cookie_without_expiry default_request default_time True $ createCookieJar []) where now_plus_diff_time = ((fromRational $ toRational default_diff_time) `addUTCTime` default_time) cookie_without_expiry = default_set_cookie {setCookieExpires = Nothing} testReceiveSetCookieNoExpiryNoMaxAge :: IO () testReceiveSetCookieNoExpiryNoMaxAge = assertBool "Expiry is set to a future date" $ default_time < (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie basic_cookie default_request default_time True $ createCookieJar []) where basic_cookie = default_set_cookie { setCookieExpires = Nothing, setCookieMaxAge = Nothing } testReceiveSetCookiePath :: IO () testReceiveSetCookiePath = assertEqual "Path gets set correctly" (fromString "/a/path") (cookie_path $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar []) where set_cookie = default_set_cookie {setCookiePath = Just $ fromString "/a/path"} testReceiveSetCookieNoPath :: IO () testReceiveSetCookieNoPath = assertEqual "Path gets set correctly when nonexistent" (fromString "/a/path/to") (cookie_path $ head $ destroyCookieJar $ receiveSetCookie set_cookie request default_time True $ createCookieJar []) where set_cookie = default_set_cookie {setCookiePath = Nothing} request = default_request {HC.path = fromString "/a/path/to/nowhere"} testReceiveSetCookieCreationTime :: IO () testReceiveSetCookieCreationTime = assertEqual "Creation time gets set correctly" now (cookie_creation_time $ head $ destroyCookieJar $ receiveSetCookie default_set_cookie default_request now True $ createCookieJar []) where now = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 1) testReceiveSetCookieAccessTime :: IO () testReceiveSetCookieAccessTime = assertEqual "Last access time gets set correctly" now (cookie_last_access_time $ head $ destroyCookieJar $ receiveSetCookie default_set_cookie default_request now True $ createCookieJar []) where now = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 1) testReceiveSetCookiePersistent :: IO () testReceiveSetCookiePersistent = assertBool "Persistent flag gets set correctly" $ cookie_persistent $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar [] where set_cookie = default_set_cookie {setCookieExpires = Just default_time} testReceiveSetCookieSecure :: IO () testReceiveSetCookieSecure = assertBool "Secure flag gets set correctly" $ cookie_secure_only $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar [] where set_cookie = default_set_cookie {setCookieSecure = True} testReceiveSetCookieMaxAge :: IO () testReceiveSetCookieMaxAge = assertEqual "Max-Age gets set correctly" total (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request now True $ createCookieJar []) where set_cookie = default_set_cookie { setCookieExpires = Nothing , setCookieMaxAge = Just $ secondsToDiffTime 10 } now = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 12) total = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 22) testReceiveSetCookiePreferMaxAge :: IO () testReceiveSetCookiePreferMaxAge = assertEqual "Max-Age is preferred over Expires" total (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request now True $ createCookieJar []) where set_cookie = default_set_cookie { setCookieExpires = Just exp , setCookieMaxAge = Just $ secondsToDiffTime 10 } exp = UTCTime (ModifiedJulianDay 11) (secondsToDiffTime 5) now = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 12) total = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 22) testReceiveSetCookieExisting :: IO () testReceiveSetCookieExisting = assertEqual "Existing cookie gets updated" t (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar [default_cookie]) where set_cookie = default_set_cookie { setCookieExpires = Just t , setCookieMaxAge = Nothing } t = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 12) testReceiveSetCookieExistingCreation :: IO () testReceiveSetCookieExistingCreation = assertEqual "Creation time gets updated in existing cookie" default_time (cookie_creation_time $ head $ destroyCookieJar $ receiveSetCookie default_set_cookie default_request now True $ createCookieJar [default_cookie]) where now = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 12) testReceiveSetCookieExistingHttpOnly :: IO () testReceiveSetCookieExistingHttpOnly = assertEqual "Existing http-only cookie gets dropped" default_time (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie default_set_cookie default_request default_time False $ createCookieJar [existing_cookie]) where existing_cookie = default_cookie {cookie_http_only = True} testMonoidPreferRecent :: IO () testMonoidPreferRecent = assertEqual "Monoid prefers more recent cookies" (cct $ createCookieJar [c2]) (cct $ createCookieJar [c1] `Data.Monoid.mappend` createCookieJar [c2]) where c1 = default_cookie {cookie_creation_time = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 1)} c2 = default_cookie {cookie_creation_time = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 2)} cct cj = cookie_creation_time $ head $ destroyCookieJar cj ipParseTests :: Spec ipParseTests = do it "Valid IP" testValidIp it "Digit Too High" testIpNumTooHigh it "Too Many Segments" testTooManySegmentsInIp it "Chars in IP" testCharsInIp domainMatchingTests :: Spec domainMatchingTests = do it "Should Match" testDomainMatchesSuccess it "Same Domain" testSameDomain it "Sibling Domain" testSiblingDomain it "Parent Domain" testParentDomain it "Checking for Naive suffix-check" testNaiveSuffixDomain defaultPathTests :: Spec defaultPathTests = do it "Basic default path test" testDefaultPath it "Basic populated default path" testPopulatedDefaultPath it "Default path from request with GET params works" testParamsDefaultPath it "Getting a default path that ends in a slash" testDefaultPathEndingInSlash it "Getting a short default path" testShortDefaultPath pathMatchingTests :: Spec pathMatchingTests = do it "Same paths match" testSamePathsMatch it "Putting slash at end" testPathSlashAtEnd it "Not putting slash at end" testPathNoSlashAtEnd it "Diverging paths don't match" testDivergingPaths equalityTests :: Spec equalityTests = do it "The same cookie should be equal to itself" testCookieEqualitySuccess it "Changing extra options shouldn't change equality" testCookieEqualityResiliance it "Changing a cookie's domain should change its equality" testDomainChangesEquality removeTests :: Spec removeTests = do it "Removing a cookie works" testRemoveCookie it "Removing a nonexistent cookie doesn't work" testRemoveNonexistantCookie it "Removing the correct cookie" testRemoveCorrectCookie evictionTests :: Spec evictionTests = do it "Testing eviction" testEvictExpiredCookies it "Evicting from empty cookie jar" testEvictNoCookies sendingTests :: Spec sendingTests = do it "Updates last access time upon using cookies" testComputeCookieStringUpdateLastAccessTime it "Host-only flag matches exact host" testComputeCookieStringHostOnly it "Host-only flag doesn't match subdomain" testComputeCookieStringHostOnlyFilter it "Domain matching works properly" testComputeCookieStringDomainMatching it "Path matching works" testComputeCookieStringPathMatching it "Path matching fails when it should" testComputeCookieStringPathMatchingFails it "Path matching succeeds when request has GET params" testComputeCookieStringPathMatchingWithParms it "Secure flag filters correctly" testComputeCookieStringSecure it "Http-only flag filters correctly" testComputeCookieStringHttpOnly it "Sorting works correctly" testComputeCookieStringSort it "Inserting cookie header works" testInsertCookiesIntoRequestWorks receivingTests :: Spec receivingTests = do it "Can receive set-cookie" testReceiveSetCookie it "Receiving a Set-Cookie with a trailing dot on the domain" testReceiveSetCookieTrailingDot it "Receiving a Set-Cookie with a leading dot on the domain" testReceiveSetCookieLeadingDot it "Set-Cookie with no domain" testReceiveSetCookieNoDomain it "Set-Cookie with empty domain" testReceiveSetCookieEmptyDomain it "Set-Cookie with non-matching domain" testReceiveSetCookieNonMatchingDomain it "Host-only flag gets set" testReceiveSetCookieHostOnly it "Host-only flag doesn't get set" testReceiveSetCookieHostOnlyNotSet it "Http-only flag gets set" testReceiveSetCookieHttpOnly it "Http-only flag doesn't get set" testReceiveSetCookieHttpOnlyNotSet it "Checking non http request gets dropped" testReceiveSetCookieHttpOnlyDrop it "Name gets set correctly" testReceiveSetCookieName it "Value gets set correctly" testReceiveSetCookieValue it "Expiry gets set correctly" testReceiveSetCookieExpiry it "Expiry gets set based on max age if no expiry is given" testReceiveSetCookieNoExpiry it "Expiry gets set based on given value if no max age is given" testReceiveSetCookieNoMaxAge it "Expiry gets set to a future date if no expiry and no max age are given" testReceiveSetCookieNoExpiryNoMaxAge it "Path gets set correctly when nonexistent" testReceiveSetCookieNoPath it "Path gets set correctly" testReceiveSetCookiePath it "Creation time gets set correctly" testReceiveSetCookieCreationTime it "Last access time gets set correctly" testReceiveSetCookieAccessTime it "Persistent flag gets set correctly" testReceiveSetCookiePersistent it "Existing cookie gets updated" testReceiveSetCookieExisting it "Creation time gets updated in existing cookie" testReceiveSetCookieExistingCreation it "Existing http-only cookie gets dropped" testReceiveSetCookieExistingHttpOnly it "Secure flag gets set correctly" testReceiveSetCookieSecure it "Max-Age flag gets set correctly" testReceiveSetCookieMaxAge it "Max-Age is preferred over Expires" testReceiveSetCookiePreferMaxAge monoidTests :: Spec monoidTests = do it "Monoid prefers more recent cookies" testMonoidPreferRecent cookieTest :: Spec cookieTest = do describe "ipParseTests" ipParseTests describe "domainMatchingTests" domainMatchingTests describe "defaultPathTests" defaultPathTests describe "pathMatchingTests" pathMatchingTests describe "equalityTests" equalityTests describe "removeTests" removeTests describe "evictionTests" evictionTests describe "sendingTests" sendingTests describe "receivingTests" receivingTests describe "monoidTest" monoidTests http-conduit-2.3.7.1/LICENSE0000644000000000000000000000253012632352123013476 0ustar0000000000000000The following license covers this documentation, and the source code, except where otherwise indicated. Copyright 2010, Michael Snoyman. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. http-conduit-2.3.7.1/Setup.lhs0000755000000000000000000000021712632352123014304 0ustar0000000000000000#!/usr/bin/env runhaskell > module Main where > import Distribution.Simple > import System.Cmd (system) > main :: IO () > main = defaultMain http-conduit-2.3.7.1/http-conduit.cabal0000644000000000000000000000546513462046532016117 0ustar0000000000000000name: http-conduit version: 2.3.7.1 license: BSD3 license-file: LICENSE author: Michael Snoyman maintainer: Michael Snoyman synopsis: HTTP client package with conduit interface and HTTPS support. description: Hackage documentation generation is not reliable. For up to date documentation, please see: . category: Web, Conduit stability: Stable cabal-version: >= 1.8 build-type: Simple homepage: http://www.yesodweb.com/book/http-conduit extra-source-files: test/main.hs , test/CookieTest.hs , multipart-example.bin , nyan.gif , certificate.pem , key.pem , README.md , ChangeLog.md library build-depends: base >= 4 && < 5 , aeson >= 0.8 , attoparsec , bytestring >= 0.9.1.4 , transformers >= 0.2 , resourcet >= 1.1 , conduit >= 1.2 , conduit-extra >= 1.1 , http-types >= 0.7 , http-client >= 0.5.13 && < 0.7 , http-client-tls >= 0.3 && < 0.4 , mtl , unliftio-core if !impl(ghc>=7.9) build-depends: void >= 0.5.5 exposed-modules: Network.HTTP.Conduit Network.HTTP.Client.Conduit Network.HTTP.Simple ghc-options: -Wall test-suite test main-is: main.hs other-modules: CookieTest type: exitcode-stdio-1.0 hs-source-dirs: test ghc-options: -Wall cpp-options: -DDEBUG build-depends: base >= 4 && < 5 , HUnit , hspec >= 1.3 , data-default-class , connection >= 0.2 , warp-tls , time , blaze-builder , bytestring , text , transformers , conduit >= 1.1 , utf8-string , case-insensitive , unliftio , network , wai >= 3.0 && < 3.3 , warp >= 3.0.0.2 && < 3.3 , wai-conduit , http-types , cookie , http-client , http-conduit , conduit-extra , streaming-commons , aeson , temporary , resourcet source-repository head type: git location: git://github.com/snoyberg/http-client.git http-conduit-2.3.7.1/multipart-example.bin0000644000000000000000000001025312632352123016636 0ustar0000000000000000-----------------------------190723902820679116301912680260 Content-Disposition: form-data; name="email" -----------------------------190723902820679116301912680260 Content-Disposition: form-data; name="parent_id" 70488 -----------------------------190723902820679116301912680260 Content-Disposition: form-data; name="captcha" -----------------------------190723902820679116301912680260 Content-Disposition: form-data; name="homeboard" 0chan.hk -----------------------------190723902820679116301912680260 Content-Disposition: form-data; name="text" >>72127 Мы работаем над этим. -----------------------------190723902820679116301912680260 Content-Disposition: form-data; name="upload"; filename="nyan.gif" Content-Type: image/gif GIF89a5̙33f3!  ! NETSCAPE2.0,4Ig֊`ef(#l D:07!c`2t:U5Xz,sFzن0q80@jr:Ntz=vi~z bvuz~yrN: J 1¶ JvǮ<1Icڅ1 7;" /-haG%ʐo9 Α(qŋ>\(# !  ,5p)R̺`aZi #l̘tD:0x%7!c`2tJU5Xzlm-F`^S`88Xs:N{wfv|mlJw|{ ks:1XLVv wtwѭO <ɐ(ѡŋ <\81 G !  ,59R'$chj 麌 t-3 i2pHprPJ}fl HM3@.[%+yN^0|rvuxCT|n&{ vP|'xCH&]R ){8ƸD| ʭEz ' O8@]* Z٠k{ Qa?ӏ#jpbBG?6!  ,5)R'Ŝh`钌 t-3i1aH,g8MolFBb8-\(# !  ,5p)R̺`aZi #l̘tD:0x%7!c`2tJU5Xzlm-F`^S`88Xs:N{wfv|mlJw|{ ks:1XLVv wtwѭO <ɐ(ѡŋ <\81 G !  ,59R'$chj 麌 t-3 i2pHprPJ}fl HM3@.[%+yN^0|rvuxCT|n&{ vP|'xCH&]R ){8ƸD| ʭEz ' O8@]* Z٠k{ Qa?ӏ#jpbBG?6!  ,5)R'Ŝh`钌 t-3i1aH,g8MolFBb8- http-conduit-2.3.7.1/ChangeLog.md0000644000000000000000000000531413462041703014646 0ustar0000000000000000# ChangeLog for http-conduit ## 2.3.7.1 * Properly skip whitespace after JSON body [#401](https://github.com/snoyberg/http-client/issues/401) ## 2.3.7 * Ensure entire JSON response body is consumed [#395](https://github.com/snoyberg/http-client/issues/395) ## 2.3.6.1 * Add back compatibility with older http-client version [#393](https://github.com/snoyberg/http-client/pull/393) ## 2.3.6 * Add `httpSource` to `Network.HTTP.Client.Conduit` [#390](https://github.com/snoyberg/http-client/pull/390). ## 2.3.5 * Adds `addToRequestQueryString` helper function ## 2.3.4 * Reexport RequestHeaders from Network.HTTP.Types (what was intended in last version) * Fix mistake in ChangeLog ## 2.3.3 * Reexport Header, QueryItem and ResponseHeaders from Network.HTTP.Types * Rewrite a type signature of setRequestHeaders with RequestHeaders ## 2.3.2 * Adds `parseRequestThrow`, `parseRequestThrow_`, and `setRequestCheckStatus` to `Network.HTTP.Simple`. See [#304](https://github.com/snoyberg/http-client/issues/304) ## 2.3.1 * Reexport Query from Network.HTTP.Types * Rewrite a type signatures of getRequestQueryString and setRequestQueryString with Query ## 2.3.0 * conduit 1.3 support * NOTE: Even for older versions of conduit, this includes dropping support for finalizers * `http` returns a `Source` instead of a `ResumableSource` (due to lack of finalizers) * Drop monad-control for unliftio * Removed some deprecated functions: `withManager`, `withManagerSettings`, `conduitManagerSettings` ## 2.2.4 * Add `httpBS` to `Network.HTTP.Simple` ## 2.2.3.2 * Add proper headers for `httpJSON` and `httpJSONEither` [#284](https://github.com/snoyberg/http-client/issues/284) ## 2.2.3.1 * Minor README improvement ## 2.2.3 * Add `withResponse` to `Network.HTTP.Simple` ## 2.2.2.1 * setRequestBodyJSON works with aeson's toEncoding function (>= 0.11) [#230](https://github.com/snoyberg/http-client/pull/230) ## 2.2.2 * Add `httpNoBody` to `Network.HTTP.Simple` ## 2.2.1 * Add `httpSource` to `Network.HTTP.Simple` ## 2.2.0.1 * Doc fixes ## 2.2.0 * Upgrade to http-client 0.5 ## 2.1.11 * Switch to non-throwing behavior in `Network.HTTP.Simple` [#193](https://github.com/snoyberg/http-client/issues/193) ## 2.1.10.1 * Fix mistaken `@since` comments ## 2.1.10 * Add the `Network.HTTP.Simple` module ## 2.1.9 * cabal file cleanup ## 2.1.8 * Move HasHttpManager from http-conduit to http-client [#147](https://github.com/snoyberg/http-client/pull/147) ## 2.1.7 * Deprecate `conduitManagerSettings`, re-export `tlsManagerSettings` [#136](https://github.com/snoyberg/http-client/issues/136) [#137](https://github.com/snoyberg/http-client/issues/137) ## 2.1.6 * Deprecate `withManager` and `withManagerSettings`