http-conduit 1.9.6 → 2.3.9.1
raw patch · 21 files changed
Files
- ChangeLog.md +155/−0
- Network/HTTP/Client/Conduit.hs +192/−0
- Network/HTTP/Conduit.hs +181/−237
- Network/HTTP/Conduit/Chunk.hs +0/−66
- Network/HTTP/Conduit/ConnInfo.hs +0/−199
- Network/HTTP/Conduit/Cookies.hs +0/−233
- Network/HTTP/Conduit/Internal.hs +0/−101
- Network/HTTP/Conduit/Manager.hs +0/−518
- Network/HTTP/Conduit/MultipartFormData.hs +0/−221
- Network/HTTP/Conduit/Parser.hs +0/−95
- Network/HTTP/Conduit/Request.hs +0/−340
- Network/HTTP/Conduit/Response.hs +0/−207
- Network/HTTP/Conduit/Types.hs +0/−319
- Network/HTTP/Conduit/Util.hs +0/−84
- Network/HTTP/Simple.hs +521/−0
- README.md +10/−0
- certificate.pem +15/−0
- http-conduit.cabal +57/−102
- key.pem +15/−0
- test/CookieTest.hs +166/−146
- test/main.hs +347/−183
+ ChangeLog.md view
@@ -0,0 +1,155 @@+# ChangeLog for http-conduit++## 2.3.9.1++* data-default-class -> data-default [#546](https://github.com/snoyberg/http-client/pull/546/files)++## 2.3.9++* Fix space leaks when closing responses [#539](https://github.com/snoyberg/http-client/pull/539)++## 2.3.8.3++* aeson 2.2 support [#512](https://github.com/snoyberg/http-client/pull/512)++## 2.3.8.2++* Add missing `crypton-connection` dependency++## 2.3.8.1++* Drop `connection` dependency++## 2.3.8++* Adds `setRequestBearerAuth` convenience function. Note that this is only available for `http-client` versions 0.7.6 or greater. [#457](https://github.com/snoyberg/http-client/pull/457/files)+* Adds a convenience function to set a request's response timeout [#456](https://github.com/snoyberg/http-client/pull/456)++## 2.3.7.4++* Introduces the `aeson` cabal file [#448](https://github.com/snoyberg/http-client/issues/448)++## 2.3.7.3++* Relax test suite version bounds++## 2.3.7.2++* Add the `network3` flag++## 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`
+ Network/HTTP/Client/Conduit.hs view
@@ -0,0 +1,192 @@+{-# 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:+--+-- <https://haskell-lang.org/library/http-client>+--+-- 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
Network/HTTP/Conduit.hs view
@@ -1,8 +1,20 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE CPP #-}-{-# LANGUAGE ScopedTypeVariables #-}--- | This module contains everything you need to initiate HTTP connections. If+{-# 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:+--+-- <https://haskell-lang.org/library/http-client>+--+-- = 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:@@ -16,16 +28,18 @@ -- This example uses interleaved IO to write the response body to a file in -- constant memory space. ----- > import Data.Conduit.Binary (sinkFile)+-- > import Data.Conduit.Binary (sinkFile) -- Exported from the package conduit-extra -- > import Network.HTTP.Conduit--- > import qualified Data.Conduit as C+-- > import Conduit (runConduit, (.|))+-- > import Control.Monad.Trans.Resource (runResourceT) -- > -- > main :: IO () -- > main = do--- > request <- parseUrl "http://google.com/"--- > withManager $ \manager -> do+-- > request <- parseRequest "http://google.com/"+-- > manager <- newManager tlsManagerSettings+-- > runResourceT $ do -- > response <- http request manager--- > responseBody response C.$$+- sinkFile "google.html"+-- > runConduit $ responseBody response .| sinkFile "google.html" -- -- The following headers are automatically set by this module, and should not -- be added to 'requestHeaders':@@ -50,6 +64,7 @@ -- > 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)@@ -71,27 +86,19 @@ -- > , cookie_http_only = False -- > } -- >--- > main = withSocketsDo $ do--- > request' <- parseUrl "http://example.com/secret-page"+-- > main = do+-- > request' <- parseRequest "http://example.com/secret-page"+-- > manager <- newManager tlsManagerSettings -- > let request = request' { cookieJar = Just $ createCookieJar [cookie] }--- > E.catch (withManager $ httpLbs request)--- > (\(StatusCodeException s _ _) ->--- > if statusCode==403 then putStrLn "login failed" else return ())------ Any network code on Windows requires some initialization, and the network--- library provides withSocketsDo to perform it. Therefore, proper usage of--- this library will always involve calling that function at some point. The--- best approach is to simply call them at the beginning of your main function,--- such as:+-- > 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) ----- > import Network.HTTP.Conduit--- > import qualified Data.ByteString.Lazy as L--- > import Network (withSocketsDo)--- >--- > main = withSocketsDo--- > $ simpleHttp "http://www.haskell.org/" >>= L.putStr--- >--- > Cookies are implemented according to RFC 6265.+-- 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@@ -103,11 +110,32 @@ -- > import Network -- > -- > main :: IO ()--- > main = withSocketsDo $ do--- > request' <- parseUrl "http://www.yesodweb.com/does-not-exist"--- > let request = request' { checkStatus = \_ _ -> Nothing }--- > res <- withManager $ httpLbs request+-- > 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@@ -118,10 +146,8 @@ , RequestBody (..) -- ** Request , Request- , def , method , secure- , clientCertificates , host , port , path@@ -129,15 +155,23 @@ , requestHeaders , requestBody , proxy- , socksProxy , hostAddress , rawBody , decompress , redirectCount- , checkStatus+#if MIN_VERSION_http_client(0,6,2)+ , shouldStripHeaderOnRedirect+#endif+ , checkResponse , responseTimeout , cookieJar- , getConnectionWrapper+ , requestVersion+ , HCC.setQueryString+ -- *** Request body+ , requestBodySource+ , requestBodySourceChunked+ , requestBodySourceIO+ , requestBodySourceChunkedIO -- * Response , Response , responseStatus@@ -145,21 +179,23 @@ , responseHeaders , responseBody , responseCookieJar+ , responseEarlyHints -- * Manager , Manager , newManager , closeManager- , withManager- , withManagerSettings -- ** Settings , ManagerSettings- , conduitManagerSettings+ , tlsManagerSettings+ , mkManagerSettings , managerConnCount- , managerCheckCerts- , managerCertStore , managerResponseTimeout- -- *** Defaults- , defaultCheckCerts+ , managerTlsConnection+ -- ** Response timeout+ , HC.ResponseTimeout+ , HC.responseTimeoutMicro+ , HC.responseTimeoutNone+ , HC.responseTimeoutDefault -- * Cookies , Cookie(..) , CookieJar@@ -167,6 +203,10 @@ , destroyCookieJar -- * Utility functions , parseUrl+ , parseUrlThrow+ , parseRequest+ , parseRequest_+ , defaultRequest , applyBasicAuth , addProxy , lbsResponse@@ -175,178 +215,43 @@ , alwaysDecompress , browserDecompress -- * Request bodies- -- | "Network.HTTP.Conduit.MultipartFormData" provides an API for building+ -- | "Network.HTTP.Client.MultipartFormData" provides an API for building -- form-data request bodies. , urlEncodedBody -- * Exceptions , HttpException (..)-#if DEBUG- -- * Debug- , printOpenSockets-#endif+ , HCC.HttpExceptionContent (..) ) where -import qualified Data.ByteString as S-import qualified Data.ByteString.Lazy as L--import qualified Network.HTTP.Types as W-import Data.Default (def)--import Control.Exception.Lifted (throwIO, try, IOException, handle, fromException, toException)-import qualified Network.TLS as TLS-import Control.Applicative-import Control.Monad ((<=<))-import Control.Monad.IO.Class (MonadIO (liftIO))-import Control.Monad.Trans.Resource--import qualified Data.Conduit as C-import Data.Conduit.Blaze (builderToByteString)--import Data.Time.Clock--import Network.HTTP.Conduit.Request-import Network.HTTP.Conduit.Response-import Network.HTTP.Conduit.Manager-import Network.HTTP.Conduit.ConnInfo-import Network.HTTP.Conduit.Cookies-import Network.HTTP.Conduit.Internal (httpRedirect, applyCheckStatus)-import Network.HTTP.Conduit.Types---- | The most low-level function for initiating an HTTP request.------ The first argument to this function gives a full specification--- on the request: the host to connect to, whether to use SSL,--- headers, etc. Please see 'Request' for full details. The--- second argument specifies which 'Manager' should be used.------ This function then returns a 'Response' with a--- 'C.Source'. The 'Response' contains the status code--- and headers that were sent back to us, and the--- 'C.Source' contains the body of the request. Note--- that this 'C.Source' allows you to have fully--- interleaved IO actions during your HTTP download, making it--- possible to download very large responses in constant memory.--- You may also directly connect the returned 'C.Source'--- into a 'C.Sink', perhaps a file or another socket.------ An important note: the response body returned by this function represents a--- live HTTP connection. As such, if you do not use the response body, an open--- socket will be retained until the containing @ResourceT@ block exits. If you--- do not need the response body, it is recommended that you explicitly shut--- down the connection immediately, using the pattern:------ > responseBody res $$+- return ()------ As a more thorough example, consider the following program. Without the--- explicit response body closing, the program will run out of file descriptors--- around the 1000th request (depending on the operating system limits).------ > import Control.Monad (replicateM_)--- > import Control.Monad.IO.Class (liftIO)--- > import Data.Conduit (($$+-))--- > import Network (withSocketsDo)--- > import Network.HTTP.Conduit--- >--- > main = withSocketsDo $ withManager $ \manager -> do--- > req <- parseUrl "http://localhost/"--- > mapM_ (worker manager req) [1..5000]--- >--- > worker manager req i = do--- > res <- http req manager--- > responseBody res $$+- return () -- The important line--- > liftIO $ print (i, responseStatus res)------ Note: Unlike previous versions, this function will perform redirects, as--- specified by the 'redirectCount' setting.-http- :: (MonadResource m, MonadBaseControl IO m)- => Request m- -> Manager- -> m (Response (C.ResumableSource m S.ByteString))-http req0 manager = wrapIOException $ 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) (W.statusCode (responseStatus res))- return (res, mreq))- id- req'---- | Get a 'Response' without any redirect following.-httpRaw- :: (MonadBaseControl IO m, MonadResource m)- => Request m- -> Manager- -> m (Response (C.ResumableSource m S.ByteString))-httpRaw req' m = do- (req, cookie_jar') <- case cookieJar req' of- Just cj -> do- now <- liftIO getCurrentTime- return $ insertCookiesIntoRequest req' (evictExpiredCookies cj now) now- Nothing -> return (req', def)- (timeout', (connRelease, ci, isManaged)) <- getConnectionWrapper- req- (responseTimeout' req)- (failedConnectionException req)- (getConn req m)- let src = connSource ci-- -- 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 C.$$ builderToByteString C.=$ connSink ci-- getResponse connRelease timeout' req src-- case (ex, isManaged) of- -- Connection was reused, and might have been closed. Try again- (Left e, Reused) | isRetryableException e -> do- connRelease DontReuse- http req m- -- Not reused, or a non-retry, so this is a real exception- (Left e, _) -> liftIO $ 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' <- liftIO 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+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 - -- 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.- isRetryableException e- | ((fromException e)::(Maybe TLS.TLSError))==Just TLS.Error_EOF = True- | otherwise = 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+import qualified Network.HTTP.Client as Client (httpLbs, responseOpen)+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 (ResponseClose (..), addProxy, alwaysDecompress,+ browserDecompress, 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'. --@@ -363,35 +268,22 @@ -- 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 :: (MonadBaseControl IO m, MonadResource m) => Request m -> Manager -> m (Response L.ByteString)-httpLbs r = wrapIOException . (lbsResponse <=< http r)--wrapIOException :: MonadBaseControl IO m => m a -> m a-wrapIOException =- handle $ throwIO . wrapper- where- wrapper se =- case fromException se of- Just e -> toException $ InternalIOException e- Nothing ->- case fromException se of- Just TLS.Terminated{} -> toException $ TlsException se- Nothing ->- case fromException se of- Just TLS.HandshakeFailed{} -> toException $ TlsException se- Nothing ->- case fromException se of- Just TLS.ConnectionNotEstablished -> toException $ TlsException se- Nothing -> se+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 'parseUrl' to parse the+-- 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@@ -402,13 +294,65 @@ -- Note: This function creates a new 'Manager'. It should be avoided -- in production code. simpleHttp :: MonadIO m => String -> m L.ByteString-simpleHttp url = liftIO $ withManager $ \man -> do- req <- liftIO $ parseUrl url- responseBody <$> httpLbs (setConnectionClose req) man+simpleHttp url = liftIO $ do+ man <- newManager tlsManagerSettings+ req <- liftIO $ parseUrlThrow url+ responseBody A.<$> httpLbs (setConnectionClose req) man -setConnectionClose :: Request m -> Request m+setConnectionClose :: Request -> Request setConnectionClose req = req{requestHeaders = ("Connection", "close") : requestHeaders req} --- | Since 1.9.6-conduitManagerSettings :: ManagerSettings-conduitManagerSettings = def+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 = resourceMask $ \_ -> do+ res <- liftIO $ Client.responseOpen req man+ -- Move the cleanup action for the response into `ResourceT` so+ -- that we can release it from the `ReleaseMap` as soon as the+ -- response is closed or the body is consumed.+ let ResponseClose cleanup = responseClose' res+ key <- register cleanup+ pure res { responseClose' = ResponseClose $ release key+ , 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
− Network/HTTP/Conduit/Chunk.hs
@@ -1,66 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-module Network.HTTP.Conduit.Chunk- ( chunkedConduit- , chunkIt- ) where--import Numeric (showHex)--import qualified Data.ByteString as S-import qualified Data.ByteString.Char8 as S8--import Blaze.ByteString.Builder.HTTP-import qualified Blaze.ByteString.Builder as Blaze--import Data.Conduit-import qualified Data.Conduit.Binary as CB--import Control.Monad (when, unless)-import Control.Exception (assert)-import Data.Maybe (fromMaybe)-import Network.HTTP.Conduit.Types (HttpException (InvalidChunkHeaders))--chunkedConduit :: MonadThrow m- => Bool -- ^ send the headers as well, necessary for a proxy- -> Conduit S.ByteString m S.ByteString-chunkedConduit sendHeaders = do- mi <- getLen- i <- maybe (monadThrow InvalidChunkHeaders) return mi- when sendHeaders $ yield $ S8.pack $ showHex i "\r\n"- CB.isolate i- CB.drop 2- when sendHeaders $ yield $ S8.pack "\r\n"- unless (i == 0) $ chunkedConduit sendHeaders- where- getLen =- start Nothing- where- start i = await >>= maybe (return i) (go i)-- go i bs =- case S.uncons bs of- Nothing -> start i- Just (w, bs') ->- case toI w of- Just i' -> go (Just $ fromMaybe 0 i * 16 + i') bs'- Nothing -> do- stripNewLine bs- return i-- stripNewLine bs =- case S.uncons $ S.dropWhile (/= 10) bs of- Just (10, bs') -> leftover bs'- Just _ -> assert False $ await >>= maybe (return ()) stripNewLine- Nothing -> await >>= maybe (return ()) stripNewLine-- 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--chunkIt :: Monad m => Conduit Blaze.Builder m Blaze.Builder-chunkIt =- await >>= maybe- (yield chunkedTransferTerminator)- (\x -> yield (chunkedTransferEncoding x) >> chunkIt)
− Network/HTTP/Conduit/ConnInfo.hs
@@ -1,199 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE CPP #-}-module Network.HTTP.Conduit.ConnInfo- ( ConnInfo- , connClose- , connSink- , connSource- , sslClientConn- , socketConn- , CertificateRejectReason(..)- , CertificateUsage(..)- , getSocket-#if DEBUG- , printOpenSockets- , requireAllSocketsClosed- , clearSocketsList-#endif- ) where--import Control.Exception (IOException, bracketOnError, throwIO)-import qualified Control.Exception as E-import System.IO (Handle, hClose)--import Control.Monad.IO.Class (liftIO)--import Data.ByteString (ByteString)-import qualified Data.ByteString as S-import qualified Data.ByteString.Lazy as L--import Network (PortID(..))-import Network.Socket (Socket, sClose, AddrInfo)-import Network.Socket.ByteString (recv, sendAll)-import qualified Network.Socket as NS-import Network.Socks5 (socksConnectWith, SocksConf)--import Network.TLS-import Network.TLS.Extra (ciphersuite_all)--import Data.Certificate.X509 (X509)--import Crypto.Random.AESCtr (makeSystem)--import Data.Conduit--#if DEBUG-import qualified Data.IntMap as IntMap-import qualified Data.IORef as I-import System.IO.Unsafe (unsafePerformIO)-#endif--data ConnInfo = ConnInfo- { connRead :: IO ByteString- , connWrite :: ByteString -> IO ()- , connClose :: IO ()- }--connSink :: MonadResource m => ConnInfo -> Sink ByteString m ()-connSink ConnInfo { connWrite = write } =- self- where- self = await >>= maybe (return ()) (\x -> liftIO (write x) >> self)--connSource :: MonadResource m => ConnInfo -> Source m ByteString-connSource ConnInfo { connRead = read' } =- self- where- self = do- bs <- liftIO read'- if S.null bs- then return ()- else yield bs >> self--#if DEBUG-allOpenSockets :: I.IORef (Int, IntMap.IntMap String)-allOpenSockets = unsafePerformIO $ I.newIORef (0, IntMap.empty)--addSocket :: String -> IO Int-addSocket desc = I.atomicModifyIORef allOpenSockets $ \(next, m) ->- ((next + 1, IntMap.insert next desc m), next)--removeSocket :: Int -> IO ()-removeSocket i = I.atomicModifyIORef allOpenSockets $ \(next, m) ->- ((next, IntMap.delete i m), ())--printOpenSockets :: IO ()-printOpenSockets = do- (_, m) <- I.readIORef allOpenSockets- putStrLn "\n\nOpen sockets:"- if IntMap.null m- then putStrLn "** No open sockets!"- else mapM_ putStrLn $ IntMap.elems m--requireAllSocketsClosed :: IO ()-requireAllSocketsClosed = do- (_, m) <- I.readIORef allOpenSockets- if IntMap.null m- then return ()- else error $ unlines- $ "requireAllSocketsClosed: there are open sockets"- : IntMap.elems m--clearSocketsList :: IO ()-clearSocketsList = I.writeIORef allOpenSockets (0, IntMap.empty)-#endif--socketConn :: String -> Socket -> IO ConnInfo-socketConn _desc sock = do-#if DEBUG- i <- addSocket _desc-#endif- return ConnInfo- { connRead = recv sock 4096- , connWrite = sendAll sock- , connClose = do-#if DEBUG- removeSocket i-#endif- sClose sock- }--sslClientConn :: String -> String -> ([X509] -> IO CertificateUsage) -> [(X509, Maybe PrivateKey)] -> Handle -> IO ConnInfo-sslClientConn _desc host onCerts clientCerts h = do-#if DEBUG- i <- addSocket _desc-#endif- let setCParams cparams = cparams- { onCertificateRequest = const (return clientCerts)- , clientUseServerName = Just host- }- tcp = updateClientParams setCParams $ defaultParamsClient- { pConnectVersion = TLS10- , pAllowedVersions = [ TLS10, TLS11, TLS12 ]- , pCiphers = ciphersuite_all- , onCertificatesRecv = onCerts- , pCertificates = clientCerts- }- gen <- makeSystem- istate <- contextNewOnHandle h tcp gen- handshake istate- return ConnInfo- { connRead = recvD istate- , connWrite = sendData istate . L.fromChunks . (:[])- , connClose = do-#if DEBUG- removeSocket i-#endif- (bye istate `E.finally` hClose h) `E.catch`- \(_ :: E.IOException) -> return ()- }- where- recvD istate = E.handle onEOF $ do- x <- recvData istate- if S.null x- then recvD istate- else return x- onEOF Error_EOF = return S.empty- onEOF e = throwIO e--getSocket :: Maybe NS.HostAddress -> String -> Int -> Maybe SocksConf -> IO NS.Socket-getSocket _ host' port' (Just socksConf) = do- socksConnectWith socksConf host' (PortNumber $ fromIntegral port')-getSocket hostAddress' host' port' Nothing = 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 ->- 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)- return sock)--firstSuccessful :: [AddrInfo] -> (AddrInfo -> IO a) -> IO a-firstSuccessful [] _ = error "getAddrInfo returned empty list"-firstSuccessful (a:as) cb =- cb a `E.catch` \(e :: IOException) ->- case as of- [] -> throwIO e- _ -> firstSuccessful as cb
− Network/HTTP/Conduit/Cookies.hs
@@ -1,233 +0,0 @@--- | This module implements the algorithms described in RFC 6265 for the Network.HTTP.Conduit library.-module Network.HTTP.Conduit.Cookies where--import qualified Data.ByteString as BS-import qualified Data.ByteString.Char8 as S8-import qualified Data.ByteString.UTF8 as U-import Text.Regex-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.Conduit.Request as Req-import qualified Network.HTTP.Conduit.Response as Res-import Network.HTTP.Conduit.Types--slash :: Integral a => a-slash = 47 -- '/'--isIpAddress :: BS.ByteString -> Bool-isIpAddress a = case strs of- Just strs' -> helper strs'- Nothing -> False- where s = U.toString a- regex = mkRegex "^([0-9]{1,3})\\.([0-9]{1,3})\\.([0-9]{1,3})\\.([0-9]{1,3})$"- strs = matchRegex regex s- helper l = length l == 4 && all helper2 l- helper2 v = (read v :: Int) >= 0 && (read v :: Int) < 256---- | 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) == U.fromString "." && 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 m -> BS.ByteString-defaultPath req- | BS.null uri_path = U.fromString "/"- | BS.singleton (BS.head uri_path) /= U.fromString "/" = U.fromString "/"- | BS.count slash uri_path <= 1 = U.fromString "/"- | 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) == U.fromString "/" = True- | cookiePath `BS.isPrefixOf` path' && BS.singleton (BS.head remainder) == U.fromString "/" = 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 m -- ^ The request to insert into- -> CookieJar -- ^ Current cookie jar- -> UTCTime -- ^ Value that should be used as \"now\"- -> (Req.Request m, 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 $ U.fromString "Cookie", BS.empty) $ Req.requestHeaders request- (cookie_string, cookie_jar') = computeCookieString request cookie_jar now True- cookie_header = (CI.mk $ U.fromString "Cookie", cookie_string)---- | This corresponds to the algorithm described in Section 5.4 \"The Cookie Header\"-computeCookieString :: Req.Request m -- ^ Input request- -> CookieJar -- ^ Current cookie jar- -> UTCTime -- ^ Value that should be used as \"now\"- -> Bool -- ^ Whether or not this request is coming from an \"http\" source (not javascript or anything like that)- -> (BS.ByteString, CookieJar) -- ^ (Contents of a \"Cookie\" header, Updated cookie jar (last-access-time is updated))-computeCookieString request cookie_jar now is_http_api = (output_line, cookie_jar')- where matching_cookie cookie = condition1 && condition2 && condition3 && condition4- where condition1- | cookie_host_only cookie = Req.host request == cookie_domain cookie- | otherwise = domainMatches (Req.host request) (cookie_domain cookie)- condition2 = pathMatches (Req.path request) (cookie_path cookie)- condition3- | not (cookie_secure_only cookie) = True- | otherwise = Req.secure request- condition4- | not (cookie_http_only cookie) = True- | otherwise = is_http_api- matching_cookies = filter matching_cookie $ expose cookie_jar- output_cookies = map (\ c -> (cookie_name c, cookie_value c)) $ L.sort matching_cookies- output_line = toByteString $ renderCookies $ output_cookies- folding_function cookie_jar'' cookie = case removeExistingCookieFromCookieJar cookie cookie_jar'' of- (Just c, cookie_jar''') -> insertIntoCookieJar (c {cookie_last_access_time = now}) cookie_jar'''- (Nothing, cookie_jar''') -> cookie_jar'''- cookie_jar' = foldl folding_function cookie_jar matching_cookies---- | This applies 'receiveSetCookie' to a given Response-updateCookieJar :: Res.Response a -- ^ Response received from server- -> Req.Request m -- ^ Request which generated the response- -> UTCTime -- ^ Value that should be used as \"now\"- -> CookieJar -- ^ Current cookie jar- -> (CookieJar, Res.Response a) -- ^ (Updated cookie jar with cookies from the Response, The response stripped of any \"Set-Cookie\" header)-updateCookieJar response request now cookie_jar = (cookie_jar', response {Res.responseHeaders = other_headers})- where (set_cookie_headers, other_headers) = L.partition ((== (CI.mk $ U.fromString "Set-Cookie")) . fst) $ Res.responseHeaders response- set_cookie_data = map snd set_cookie_headers- set_cookies = map parseSetCookie set_cookie_data- cookie_jar' = foldl (\ cj sc -> receiveSetCookie sc request now True cj) cookie_jar set_cookies---- | This corresponds to the algorithm described in Section 5.3 \"Storage Model\"--- This function consists of calling 'generateCookie' followed by 'insertCheckedCookie'.--- Use this function if you plan to do both in a row.--- 'generateCookie' and 'insertCheckedCookie' are only provided for more fine-grained control.-receiveSetCookie :: SetCookie -- ^ The 'SetCookie' the cookie jar is receiving- -> Req.Request m -- ^ 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 m -- ^ 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') == U.fromString "." = Nothing- | has_a_character && BS.singleton (BS.head domain') == U.fromString "." = 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)
− Network/HTTP/Conduit/Internal.hs
@@ -1,101 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE CPP #-}-module Network.HTTP.Conduit.Internal- ( getUri- , setUri- , setUriRelative- -- * Redirect loop- , httpRedirect- , applyCheckStatus- -- * Cookie functions- , updateCookieJar- , receiveSetCookie- , generateCookie- , insertCheckedCookie- , insertCookiesIntoRequest- , computeCookieString- , evictExpiredCookies- ) where--import qualified Data.ByteString as S-import qualified Data.ByteString.Lazy as L-import qualified Data.ByteString.Char8 as S8--import Control.Exception (SomeException, toException, fromException)-import Control.Exception.Lifted (throwIO)-import Control.Monad.Trans.Resource--import qualified Data.Conduit as C-import qualified Data.Conduit.Binary as CB-import qualified Data.Conduit.Internal as CI-import Data.Conduit.List (sinkNull)--import Network.HTTP.Conduit.Request-import Network.HTTP.Conduit.Response-import Network.HTTP.Conduit.Cookies-import Network.HTTP.Conduit.Types-import Network.HTTP.Types---- | Redirect loop-httpRedirect- :: (MonadBaseControl IO m, MonadResource m, Monad m1)- => Int -- ^ 'redirectCount'- -> (Request m1 -> m (Response (C.ResumableSource m1 S.ByteString), Maybe (Request m1))) -- ^ function which performs a request and returns a response, and possibly another request if there's a redirect.- -> (forall a. m1 a -> m a) -- ^ 'liftResourceT'- -> Request m1- -> m (Response (C.ResumableSource m1 S.ByteString))-httpRedirect count0 http' lift' req0 = go count0 req0 []- where- go (-1) _ ress = throwIO . TooManyRedirects =<< lift' (mapM lbsResponse ress)- go count req' ress = do- (res, mreq) <- http' req'- case mreq of- Just req -> do- -- 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- sink =- case lookup "content-length" (responseHeaders res) >>= readMay of- Just i | i > maxFlush -> return ()- _ -> CB.isolate maxFlush C.=$ sinkNull- lift' $ responseBody res C.$$+- sink-- -- And now perform the actual redirect- go (count - 1) req (res:ress)- Nothing -> return res---- | Apply 'Request'\'s 'checkStatus' and return resulting exception if any.-applyCheckStatus- :: (MonadResource m, MonadBaseControl IO m)- => (Status -> ResponseHeaders -> CookieJar -> Maybe SomeException)- -> Response (C.ResumableSource m S.ByteString)- -> m (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 <- (responseBody res) C.$$+- CB.take 1024- return $ toException $ StatusCodeException s (hdrs ++- [("X-Response-Body-Start", toStrict' lbs)]) cookie_jar- _ -> do- let CI.ResumableSource _ final = (responseBody res)- final- return exc- return (Just exc')- where-#if MIN_VERSION_bytestring(0,10,0)- toStrict' = L.toStrict-#else- toStrict' = S.concat . L.toChunks-#endif
− Network/HTTP/Conduit/Manager.hs
@@ -1,518 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-}-module Network.HTTP.Conduit.Manager- ( Manager- , mResponseTimeout- , ManagerSettings (..)- , ConnKey (..)- , ConnHost (..)- , newManager- , closeManager- , getConn- , ConnReuse (..)- , withManager- , withManagerSettings- , ConnRelease- , ManagedConn (..)- , defaultCheckCerts- , failedConnectionException- ) 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.Trans.Control (MonadBaseControl)-import Control.Monad.IO.Class (MonadIO, liftIO)-import Control.Exception (mask_, SomeException, catch, throwIO, fromException, IOException)-import Control.Monad.Trans.Resource- ( ResourceT, runResourceT, MonadResource- , MonadThrow, MonadUnsafeIO- , allocate, resourceMask, register, release- )-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.Certificate.X509 (X509, encodeCertificate)-import Data.CertificateStore (CertificateStore)-import System.Certificate.X509 (getSystemCertificateStore)--import Network.TLS (PrivateKey)-import Network.TLS.Extra (certificateVerifyChain, certificateVerifyDomain)--import Network.HTTP.Conduit.ConnInfo-import Network.HTTP.Conduit.Types-import Network.HTTP.Conduit.Util (hGetSome)-import Network.HTTP.Conduit.Parser (sinkHeaders)-import Network.Socks5 (SocksConf)-import Data.Default-import Data.Maybe (mapMaybe)-import System.IO (Handle)-import System.Mem.Weak (Weak, deRefWeak)-import Data.Conduit (($$), yield, runException)---- | Settings for a @Manager@. Please use the 'def' function and then modify--- individual settings.-data ManagerSettings = ManagerSettings- { managerConnCount :: Int- -- ^ Number of connections to a single host to keep alive. Default: 10.- , managerCheckCerts :: CertificateStore -> S8.ByteString -> [X509] -> IO CertificateUsage- -- ^ Check if the server certificate is valid. Only relevant for HTTPS.- , managerCertStore :: IO CertificateStore- -- ^ Load up the certificate store. By default uses the system store.- , managerResponseTimeout :: Maybe Int- -- ^ Default timeout (in microseconds) to be applied to requests which do- -- not provide a timeout value.- --- -- Default is 5 seconds- --- -- Since 1.9.3- }--type X509Encoded = L.ByteString--instance Default ManagerSettings where- def = ManagerSettings- { managerConnCount = 10- , managerCheckCerts = defaultCheckCerts- , managerCertStore = getSystemCertificateStore- , managerResponseTimeout = Just 5000000- }---- | Check certificates using the operating system's certificate checker.-defaultCheckCerts :: CertificateStore -> S8.ByteString -> [X509] -> IO CertificateUsage-defaultCheckCerts certStore host' certs =- case certificateVerifyDomain (S8.unpack host') certs of- CertificateUsageAccept -> certificateVerifyChain certStore certs- rejected -> return rejected---- | Keeps track of open connections for keep-alive.--- If possible, you should share a single 'Manager' between multiple threads and requests.-data Manager = Manager- { mConns :: !(I.IORef (Maybe (Map.Map ConnKey (NonEmptyList ConnInfo))))- -- ^ @Nothing@ indicates that the manager is closed.- , mMaxConns :: !Int- -- ^ This is a per-@ConnKey@ value.- , mCheckCerts :: S8.ByteString -> [X509] -> IO CertificateUsage- -- ^ Check if a certificate is valid.- , mCertCache :: !(I.IORef (Map.Map S8.ByteString (Map.Map X509Encoded UTCTime)))- -- ^ Cache of validated certificates. The @UTCTime@ gives the expiration- -- time for the validity of the certificate. The @Ascii@ is the hostname.- , mResponseTimeout :: !(Maybe Int)- -- ^ Copied from 'managerResponseTimeout'- }--data NonEmptyList a =- One !a !UTCTime |- Cons !a !Int !UTCTime !(NonEmptyList a)---- | Hostname or resolved host address.-data ConnHost =- HostName !Text |- HostAddress !NS.HostAddress- deriving (Eq, Show, Ord)---- | @ConnKey@ consists of a hostname, a port and a @Bool@--- specifying whether to use SSL.-data ConnKey = ConnKey !ConnHost !Int !Bool- deriving (Eq, Show, Ord)--takeSocket :: Manager -> ConnKey -> IO (Maybe ConnInfo)-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 -> ConnInfo -> IO ()-putSocket man key ci = do- now <- getCurrentTime- msock <- I.atomicModifyIORef (mConns man) (go now)- maybe (return ()) connClose msock- where- go _ Nothing = (Nothing, Just ci)- go now (Just m) =- case Map.lookup key m of- Nothing -> (Just $ Map.insert key (One ci now) m, Nothing)- Just l ->- let (l', mx) = addToList now (mMaxConns man) ci l- in (Just $ Map.insert key l' m, mx)---- | Add a new element to the list, up to the given maximum number. If we're--- already at the maximum, return the new value as leftover.-addToList :: UTCTime -> Int -> a -> NonEmptyList a -> (NonEmptyList a, Maybe a)-addToList _ i x l | i <= 1 = (l, Just x)-addToList now _ x l@One{} = (Cons x 2 now l, Nothing)-addToList now maxCount x l@(Cons _ currCount _ _)- | maxCount > currCount = (Cons x (currCount + 1) now l, Nothing)- | otherwise = (l, Just x)---- | Create a 'Manager'. You must manually call 'closeManager' to shut it down.------ Creating a new 'Manager' is an expensive operation, you are advised to share--- a single 'Manager' between requests instead.-newManager :: ManagerSettings -> IO Manager-newManager ms = do- icertStore <- I.newIORef Nothing- let getCertStore = do- mcertStore <- I.readIORef icertStore- case mcertStore of- Nothing -> do- certStore <- managerCertStore ms- I.writeIORef icertStore $ Just certStore- return certStore- Just x -> return x- mapRef <- I.newIORef (Just Map.empty)- wmapRef <- I.mkWeakIORef mapRef $ closeManager' mapRef- certCache <- I.newIORef Map.empty- _ <- forkIO $ reap wmapRef certCache- let manager = Manager- { mConns = mapRef- , mMaxConns = managerConnCount ms- , mCheckCerts = \x y -> getCertStore >>= \cs -> managerCheckCerts ms cs x y- , mCertCache = certCache- , mResponseTimeout = managerResponseTimeout ms- }- return manager---- | Collect and destroy any stale connections.-reap :: Weak (I.IORef (Maybe (Map.Map ConnKey (NonEmptyList ConnInfo))))- -> I.IORef (Map.Map S8.ByteString (Map.Map X509Encoded UTCTime))- -> IO ()-reap wmapRef certCacheRef =- 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- !() <- I.atomicModifyIORef certCacheRef $ \x -> let y = flushStaleCerts now x in y `seq` (y, ())- 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')---- | Create a new manager, use it in the provided function, and then release it.------ This function uses the default manager settings. For more control, use--- 'withManagerSettings'.-withManager :: ( MonadIO m- , MonadBaseControl IO m- , MonadThrow m- , MonadUnsafeIO m- ) => (Manager -> ResourceT m a) -> m a-withManager f = runResourceT $ do- (_, manager) <- allocate (newManager def) closeManager- f manager---- | Create a new manager with provided settings, use it in the provided function, and then release it.-withManagerSettings :: ( MonadIO m- , MonadBaseControl IO m- , MonadThrow m- , MonadUnsafeIO m- ) => ManagerSettings -> (Manager -> ResourceT m a) -> m a-withManagerSettings s f = runResourceT $ do- (_, manager) <- allocate (newManager s) closeManager- f manager---- | Close all connections in a 'Manager'. Afterwards, the 'Manager'--- can be reused if desired.------ Note that this doesn't affect currently in-flight connections,--- meaning you can safely use it without hurting any queries you may--- have concurrently running.-closeManager :: Manager -> IO ()-closeManager = closeManager' . mConns--closeManager' :: I.IORef (Maybe (Map.Map ConnKey (NonEmptyList ConnInfo)))- -> IO ()-closeManager' connsRef = mask_ $ do- m <- I.atomicModifyIORef connsRef $ \x -> (Nothing, x)- mapM_ (nonEmptyMapM_ safeConnClose) $ maybe [] Map.elems m--safeConnClose :: ConnInfo -> IO ()-safeConnClose ci = connClose ci `catch` \(_::IOException) -> 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--getSocketConn- :: Maybe NS.HostAddress- -> String- -> Int- -> Maybe SocksConf -- ^ optional socks proxy- -> IO ConnInfo-getSocketConn hostAddress' host' port' socksProxy' =- getSocket hostAddress' host' port' socksProxy' >>= socketConn desc- where- desc = socketDesc host' port' "unsecured"--socketDesc :: String -> Int -> String -> String-socketDesc h p t = unwords [h, show p, t]--getSslConn :: ([X509] -> IO CertificateUsage)- -> [(X509, Maybe PrivateKey)]- -> Maybe NS.HostAddress- -> String -- ^ host- -> Int -- ^ port- -> Maybe SocksConf -- ^ optional socks proxy- -> IO ConnInfo-getSslConn checkCert clientCerts hostAddress' host' port' socksProxy' =- connectionTo hostAddress' host' port' socksProxy' >>= sslClientConn desc host' checkCert clientCerts- where- desc = socketDesc host' port' "secured"--getSslProxyConn- :: ([X509] -> IO CertificateUsage)- -> [(X509, Maybe PrivateKey)]- -> S8.ByteString -- ^ Target host- -> Int -- ^ Target port- -> Maybe NS.HostAddress- -> String -- ^ Proxy host- -> Int -- ^ Proxy port- -> Maybe SocksConf -- ^ optional SOCKS proxy- -> IO ConnInfo-getSslProxyConn checkCert clientCerts thost tport phostAddr phost pport socksProxy' =- doConnect >>= sslClientConn desc phost checkCert clientCerts- where- desc = socketDesc phost pport "secured-proxy"- doConnect = do- h <- connectionTo phostAddr phost pport socksProxy'- L.hPutStr h $ Blaze.toLazyByteString connectRequest- hFlush h- r <- hGetSome h 2048- case runException $ yield r $$ sinkHeaders of- Right ((_, 200, _), _) -> return h- Right ((_, _, msg), _) -> hClose h >> proxyError (Left msg)- Left s -> do- hClose h- proxyError $- case fromException s of- Just he -> Right he- Nothing -> Left $ S8.pack $ show s-- connectRequest =- Blaze.fromByteString "CONNECT "- `mappend` Blaze.fromByteString thost- `mappend` Blaze.fromByteString (S8.pack (':' : show tport))- `mappend` Blaze.fromByteString " HTTP/1.1\r\n\r\n"- proxyError s = throwIO $ ProxyConnectException thost tport s---- | 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- :: MonadResource m- => Manager- -> ConnKey- -> IO ConnInfo- -> m (ConnRelease m, ConnInfo, ManagedConn)--- We want to avoid any holes caused by async exceptions, so let's mask.-getManagedConn man key open = resourceMask $ \restore -> do- -- Try to take the socket out of the manager.- mci <- liftIO $ 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 $ liftIO 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 <- liftIO $ I.newIORef DontReuse-- -- Now register our release action.- releaseKey <- register $ do- toReuse <- I.readIORef toReuseRef- -- Determine what action to take based on the value stored in the- -- toReuseRef variable.- case toReuse of- Reuse -> putSocket man key ci- DontReuse -> connClose ci-- -- When the connection is explicitly released, we update our toReuseRef to- -- indicate what action should be taken, and then call release.- let connRelease x = do- liftIO $ I.writeIORef toReuseRef x- release releaseKey- return (connRelease, ci, isManaged)---- | Create an exception to be thrown if the connection for the given request--- fails.-failedConnectionException :: Request m -> HttpException-failedConnectionException req =- FailedConnectionException host' port'- where- (_, host', port') = getConnDest req--getConnDest :: Request m -> (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 :: MonadResource m- => Request m- -> Manager- -> m (ConnRelease m, ConnInfo, ManagedConn)-getConn req m =- getManagedConn m (ConnKey connKeyHost connport (secure req)) $- go connaddr connhost connport (socksProxy req)- 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, _) -> getSocketConn- (True, False) -> getSslConn (checkCerts m h) (clientCertificates req)- (True, True) -> getSslProxyConn (checkCerts m h) (clientCertificates req) h (port req)--checkCerts :: Manager -> S8.ByteString -> [X509] -> IO CertificateUsage-checkCerts man host' certs = do-#if DEBUG- putStrLn $ "checkCerts for host: " ++ show host'-#endif- cache <- I.readIORef $ mCertCache man- case Map.lookup host' cache >>= Map.lookup encoded of- Nothing -> do-#if DEBUG- putStrLn $ concat ["checkCerts ", show host', " no cached certs found"]-#endif- res <- mCheckCerts man host' certs- case res of- CertificateUsageAccept -> do-#if DEBUG- putStrLn $ concat ["checkCerts ", show host', " valid cert, adding to cache"]-#endif- now <- getCurrentTime- -- keep it valid for 1 hour- let expire = (60 * 60) `addUTCTime` now- I.atomicModifyIORef (mCertCache man) $ addValidCerts expire- _ -> return ()- return res- Just _ -> do-#if DEBUG- putStrLn $ concat ["checkCerts ", show host', " cert already cached"]-#endif- return CertificateUsageAccept- where- encoded = L.concat $ map encodeCertificate certs- addValidCerts expire cache =- (Map.insert host' inner cache, ())- where- inner =- case Map.lookup host' cache of- Nothing -> Map.singleton encoded expire- Just m -> Map.insert encoded expire m--connectionTo :: Maybe NS.HostAddress -> NS.HostName -> Int -> Maybe SocksConf -> IO Handle-connectionTo hostAddress' host' port' socksConf' =- getSocket hostAddress' host' port' socksConf' >>= flip NS.socketToHandle ReadWriteMode
− Network/HTTP/Conduit/MultipartFormData.hs
@@ -1,221 +0,0 @@-{-# LANGUAGE CPP, OverloadedStrings #-}--- | This module handles building multipart/form-data. Example usage:------ > {-# LANGUAGE OverloadedStrings #-}--- > import Network--- > import Network.HTTP.Conduit--- > import Network.HTTP.Conduit.MultipartFormData--- >--- > import Data.Text.Encoding as TE--- >--- > import Control.Monad--- >--- > main = withSocketsDo $ withManager $ \m -> do--- > req1 <- parseUrl "http://random-cat-photo.net/cat.jpg"--- > res <- httpLbs req1 m--- > req2 <- parseUrl "http://example.org/~friedrich/blog/addPost.hs"--- > flip httpLbs m =<<--- > (formDataBody [partBS "title" "Bleaurgh"--- > ,partBS "text" $ TE.encodeUtf8 "矢田矢田矢田矢田矢田"--- > ,partFileSource "file1" "/home/friedrich/Photos/MyLittlePony.jpg"--- > ,partFileRequestBody "file2" "cat.jpg" $ RequestBodyLBS $ responseBody res]--- > req2)-module Network.HTTP.Conduit.MultipartFormData- (- -- * Part type- Part(..)- -- * Constructing parts- ,partBS- ,partLBS- ,partFile- ,partFileSource- ,partFileSourceChunked- ,partFileRequestBody- ,partFileRequestBodyM- -- * Building form data- ,formDataBody- ,formDataBodyPure- ,formDataBodyWithBoundary- -- * Boundary- ,webkitBoundary- ,webkitBoundaryPure- -- * Misc- ,renderParts- ,renderPart- ) where--import Network.HTTP.Conduit.Request-import Network.HTTP.Conduit.Util-import Network.Mime-import Network.HTTP.Types (hContentType, methodPost)--import Blaze.ByteString.Builder-import qualified Data.Conduit.List as CL-import qualified Data.Conduit.Binary as CB-import Data.Conduit--import Data.Text-import qualified Data.Text.Encoding as TE-import qualified Data.ByteString.Lazy as BL-import qualified Data.ByteString as BS--import Control.Monad.Trans.State.Strict (state, runState)-import Control.Monad.IO.Class-import System.FilePath-import System.Random-import Data.Array.Base-import System.IO-import Data.Bits-import Data.Word-import Data.Functor.Identity-import Data.Monoid (Monoid(..))-import Control.Monad---- | A single part of a multipart message.-data Part m m' = Part- { partName :: Text -- ^ Name of the corresponding \<input\>- , partFilename :: Maybe String -- ^ A file name, if this is an attached file- , partContentType :: Maybe MimeType -- ^ Content type- , partGetBody :: m (RequestBody m') -- ^ Action in m which returns the body- -- of a message.- }--instance Show (Part m m') where- showsPrec d (Part n f c _) =- showParen (d>=11) $ showString "Part "- . showsPrec 11 n- . showString " "- . showsPrec 11 f- . showString " "- . showsPrec 11 c- . showString " "- . showString "<m (RequestBody m)>"--partBS :: (Monad m, Monad m') => Text -> BS.ByteString -> Part m m'-partBS n b = Part n mempty mempty $ return $ RequestBodyBS b--partLBS :: (Monad m, Monad m') => Text -> BL.ByteString -> Part m m'-partLBS n b = Part n mempty mempty $ return $ RequestBodyLBS b---- | Make a 'Part' from a file, the entire file will reside in memory at once.--- If you want constant memory usage use 'partFileSource'-partFile :: (MonadIO m, Monad m') => Text -> FilePath -> Part m m'-partFile n f =- partFileRequestBodyM n f $ do- liftM RequestBodyBS $ liftIO $ BS.readFile f---- | Stream 'Part' from a file.-partFileSource :: (MonadIO m, MonadResource m') => Text -> FilePath -> Part m m'-partFileSource n f =- partFileRequestBodyM n f $ do- size <- liftIO $ withBinaryFile f ReadMode hFileSize- return $ RequestBodySource (fromInteger size) $- CB.sourceFile f $= CL.map fromByteString---- | 'partFileSourceChunked' will read a file and send it in chunks.------ Note that not all servers support this. Only use 'partFileSourceChunked'--- if you know the server you're sending to supports chunked request bodies.-partFileSourceChunked :: (Monad m, MonadResource m') => Text -> FilePath -> Part m m'-partFileSourceChunked n f =- partFileRequestBody n f $ do- RequestBodySourceChunked $ CB.sourceFile f $= CL.map fromByteString---- | Construct a 'Part' from form name, filepath and a 'RequestBody'------ > partFileRequestBody "who_calls" "caller.json" $ RequestBodyBS "{\"caller\":\"Jason J Jason\"}"------ > -- empty upload form--- > partFileRequestBody "file" mempty mempty-partFileRequestBody :: (Monad m, Monad m') => Text -> FilePath -> RequestBody m' -> Part m m'-partFileRequestBody n f rqb =- partFileRequestBodyM n f $ return rqb---- | Construct a 'Part' from action returning the 'RequestBody'------ > partFileRequestBodyM "cat_photo" "haskell-the-cat.jpg" $ do--- > size <- fromInteger <$> withBinaryFile "haskell-the-cat.jpg" ReadMode hFileSize--- > return $ RequestBodySource size $ CB.sourceFile "haskell-the-cat.jpg" $= CL.map fromByteString-partFileRequestBodyM :: Monad m' => Text -> FilePath -> m (RequestBody m') -> Part m m'-partFileRequestBodyM n f rqb =- Part n (Just f) (Just $ defaultMimeLookup $ pack f) rqb--{-# INLINE cp #-}-cp :: BS.ByteString -> RequestBody m-cp bs = RequestBodyBuilder (fromIntegral $ BS.length bs) $ copyByteString bs--renderPart :: (Monad m, Monad m') => BS.ByteString -> Part m m' -> m (RequestBody m')-renderPart boundary (Part name mfilename mcontenttype get) = liftM render get- where render renderBody =- cp "--" <> cp boundary <> cp "\r\n"- <> cp "Content-Disposition: form-data; name=\""- <> RequestBodyBS (TE.encodeUtf8 name)- <> (case mfilename of- Just f -> cp "\"; filename=\""- <> RequestBodyBS (TE.encodeUtf8 $ pack $ takeFileName f)- _ -> mempty)- <> cp "\""- <> (case mcontenttype of- Just ct -> cp "\r\n"- <> cp "Content-Type: "- <> cp ct- _ -> mempty)- <> cp "\r\n\r\n"- <> renderBody <> cp "\r\n"---- | Combine the 'Part's to form multipart/form-data body-renderParts :: (Monad m, Monad m') => BS.ByteString -> [Part m m'] -> m (RequestBody m')-renderParts boundary parts = (fin . mconcat) `liftM` mapM (renderPart boundary) parts- where fin = (<> cp "--" <> cp boundary <> cp "--\r\n")---- | Generate a boundary simillar to those generated by WebKit-based browsers.-webkitBoundary :: IO BS.ByteString-webkitBoundary = getStdRandom webkitBoundaryPure--webkitBoundaryPure :: RandomGen g => g -> (BS.ByteString, g)-webkitBoundaryPure g = (`runState` g) $ do- fmap (BS.append prefix . BS.pack . Prelude.concat) $ replicateM 4 $ do- randomness <- state $ random- return [unsafeAt alphaNumericEncodingMap $ randomness `shiftR` 24 .&. 0x3F- ,unsafeAt alphaNumericEncodingMap $ randomness `shiftR` 16 .&. 0x3F- ,unsafeAt alphaNumericEncodingMap $ randomness `shiftR` 8 .&. 0x3F- ,unsafeAt alphaNumericEncodingMap $ randomness .&. 0x3F]- where- prefix = "----WebKitFormBoundary"- alphaNumericEncodingMap :: UArray Int Word8- alphaNumericEncodingMap = listArray (0, 63)- [0x41, 0x42, 0x43, 0x44, 0x45, 0x46, 0x47, 0x48,- 0x49, 0x4A, 0x4B, 0x4C, 0x4D, 0x4E, 0x4F, 0x50,- 0x51, 0x52, 0x53, 0x54, 0x55, 0x56, 0x57, 0x58,- 0x59, 0x5A, 0x61, 0x62, 0x63, 0x64, 0x65, 0x66,- 0x67, 0x68, 0x69, 0x6A, 0x6B, 0x6C, 0x6D, 0x6E,- 0x6F, 0x70, 0x71, 0x72, 0x73, 0x74, 0x75, 0x76,- 0x77, 0x78, 0x79, 0x7A, 0x30, 0x31, 0x32, 0x33,- 0x34, 0x35, 0x36, 0x37, 0x38, 0x39, 0x41, 0x42]---- | Add form data to the 'Request'.------ This sets a new 'requestBody', adds a content-type request header and changes the method to POST.-formDataBody :: (MonadIO m, Monad m') => [Part m m'] -> Request m' -> m (Request m')-formDataBody a b = do- boundary <- liftIO webkitBoundary- formDataBodyWithBoundary boundary a b---- | Add form data to request without doing any IO. Your form data should only--- contain pure parts ('partBS', 'partLBS', 'partFileRequestBody'). You'll have--- to supply your own boundary (for example one generated by 'webkitBoundary')-formDataBodyPure :: Monad m => BS.ByteString -> [Part Identity m] -> Request m -> Request m-formDataBodyPure = \boundary parts req ->- runIdentity $ formDataBodyWithBoundary boundary parts req---- | Add form data with supplied boundary-formDataBodyWithBoundary :: (Monad m, Monad m') => BS.ByteString -> [Part m m'] -> Request m' -> m (Request m')-formDataBodyWithBoundary boundary parts req = do- body <- renderParts boundary parts- return $ req- { method = methodPost- , requestHeaders =- (hContentType, "multipart/form-data; boundary=" <> boundary)- : Prelude.filter (\(x, _) -> x /= hContentType) (requestHeaders req)- , requestBody = body- }
− Network/HTTP/Conduit/Parser.hs
@@ -1,95 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleContexts #-}-module Network.HTTP.Conduit.Parser- ( sinkHeaders- ) where--import Prelude hiding (take, takeWhile)-import Control.Applicative--import qualified Data.ByteString as S-import qualified Data.ByteString.Char8 as S8--import Data.Conduit (Sink, MonadThrow (monadThrow), (=$))-import Control.Monad (when, unless)-import Network.HTTP.Conduit.Types (HttpException (..))-import qualified Data.Conduit.Binary as CB-import qualified Data.Conduit.List as CL---type Header = (S.ByteString, S.ByteString)-type Status = (S.ByteString, Int, S.ByteString)---- | New version of @sinkHeaders@ that doesn't use attoparsec. Should create--- more meaningful exceptions.------ Since 1.8.7-sinkHeaders :: (MonadThrow m) => Sink S.ByteString m (Status, [Header])-sinkHeaders = do- status <- getStatusLine- headers <- parseHeaders id- return (status, 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.- mx <- CL.peek- case mx of- Nothing -> monadThrow NoResponseDataReceived- Just _ -> return ()-- status@(_, code, _) <- sinkLine >>= parseStatus- if code == 100- then newline ExpectedBlankAfter100Continue >> getStatusLine- else return status-- newline exc = do- line <- sinkLine- unless (S.null line) $ monadThrow exc-- sinkLine = do- bs <- fmap (killCR . S.concat) $ CB.takeWhile (/= charLF) =$ CL.consume- CB.drop 1- return bs- charLF = 10- charCR = 13- charSpace = 32- charColon = 58- killCR bs- | S.null bs = bs- | S.last bs == charCR = S.init bs- | otherwise = bs-- parseStatus :: MonadThrow m => S.ByteString -> m Status- 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 <*> parseCode code of- Just (ver', code') -> return (ver', code', msg)- _ -> monadThrow $ InvalidStatusLine bs-- stripPrefixBS x y- | x `S.isPrefixOf` y = Just $ S.drop (S.length x) y- | otherwise = Nothing- parseVersion = stripPrefixBS "HTTP/"- parseCode bs =- case S8.readInt bs of- Just (i, "") -> Just i- _ -> Nothing-- parseHeaders front = do- line <- sinkLine- if S.null line- then return $ front []- else do- header <- parseHeader line- parseHeaders $ front . (header:)-- parseHeader :: MonadThrow m => S.ByteString -> m Header- parseHeader bs = do- let (key, bs2) = S.breakByte charColon bs- when (S.null bs2) $ monadThrow $ InvalidHeader bs- return (strip key, strip $ S.drop 1 bs2)-- strip = S.dropWhile (== charSpace) . fst . S.spanEnd (== charSpace)
− Network/HTTP/Conduit/Request.hs
@@ -1,340 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE CPP #-}--{-# OPTIONS_GHC -fno-warn-orphans #-}--module Network.HTTP.Conduit.Request- ( Request (..)- , RequestBody (..)- , ContentType- , Proxy (..)- , parseUrl- , setUriRelative- , getUri- , setUri- , browserDecompress- , HttpException (..)- , alwaysDecompress- , addProxy- , applyBasicAuth- , urlEncodedBody- , needsGunzip- , requestBuilder- , useDefaultTimeout- ) where--import Data.Maybe (fromMaybe, isJust)-import Data.Monoid (mempty, mappend)-import Data.String (IsString(..))--import Data.Default (Default (def))--import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString)-import Blaze.ByteString.Builder.Char8 (fromChar)--import qualified Data.Conduit as C--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.Lifted (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.Conduit.Types (Request (..), RequestBody (..), ContentType, Proxy (..), HttpException (..))--import Network.HTTP.Conduit.Chunk (chunkIt)-import Network.HTTP.Conduit.Util (readDec, (<>))-import System.Timeout.Lifted (timeout)-import Data.Time.Clock---- | Convert a URL into a 'Request'.------ This defaults some of the values in 'Request', such as setting 'method' to--- GET and 'requestHeaders' to @[]@.------ Since this function uses 'Failure', the return monad can be anything that is--- an instance of 'Failure', such as 'IO' or 'Maybe'.-parseUrl :: Failure HttpException m => String -> m (Request m')-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 m' -> URI -> m (Request m')-setUriRelative req uri =-#if MIN_VERSION_network(2,4,0)- setUri req $ uri `relativeTo` getUri req-#else- case uri `relativeTo` getUri req of- Just uri' -> setUri req uri'- Nothing -> failure $ InvalidUrlException (show uri) "Invalid URL"-#endif---- | Extract a 'URI' from the request.-getUri :: Request m' -> 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 m' -> URI -> m (Request m')-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 m) where- show x = unlines- [ "Request {"- , " host = " ++ show (host x)- , " port = " ++ show (port x)- , " secure = " ++ show (secure x)- , " clientCertificates = " ++ show (clientCertificates 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 m) where- def = Request- { host = "localhost"- , port = 80- , secure = False- , clientCertificates = []- , requestHeaders = []- , path = "/"- , queryString = S8.empty- , requestBody = RequestBodyLBS L.empty- , method = "GET"- , proxy = Nothing- , socksProxy = 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 <- liftIO getCurrentTime- mres <- timeout timeout' f- case mres of- Nothing -> throwIO exc- Just res -> do- now <- liftIO 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 m) where- fromString s =- case parseUrl s of- Left e -> throw (e :: HttpException)- Right r -> r---- | Always decompress a compressed stream.-alwaysDecompress :: ContentType -> Bool-alwaysDecompress = const True---- | Decompress a compressed stream unless the content-type is 'application/x-tar'.-browserDecompress :: ContentType -> Bool-browserDecompress = (/= "application/x-tar")---- | Add a Basic Auth header (with the specified user name and password) to the--- given Request. Ignore error handling:------ applyBasicAuth "user" "pass" $ fromJust $ parseUrl url--applyBasicAuth :: S.ByteString -> S.ByteString -> Request m -> Request m-applyBasicAuth user passwd req =- req { requestHeaders = authHeader : requestHeaders req }- where- authHeader = (CI.mk "Authorization", basic)- basic = S8.append "Basic " (B64.encode $ S8.concat [ user, ":", passwd ])----- | Add a proxy to the Request so that the Request when executed will use--- the provided proxy.-addProxy :: S.ByteString -> Int -> Request m -> Request m-addProxy hst prt req =- req { proxy = Just $ Proxy hst prt }---- FIXME add a helper for generating POST bodies---- | Add url-encoded parameters to the 'Request'.------ This sets a new 'requestBody', adds a content-type request header and--- changes the 'method' to POST.-urlEncodedBody :: Monad m => [(S.ByteString, S.ByteString)] -> Request m' -> Request m-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 m- -> [W.Header] -- ^ response headers- -> Bool-needsGunzip req hs' =- not (rawBody req)- && ("content-encoding", "gzip") `elem` hs'- && decompress req (fromMaybe "" $ lookup "content-type" hs')--requestBuilder- :: Monad m- => Request m- -> C.Source m Builder-requestBuilder req =- bodySource- where- (contentLength, bodySource) =- case requestBody req of- RequestBodyLBS lbs -> (Just $ L.length lbs, C.yield $ builder `mappend` fromLazyByteString lbs)- RequestBodyBS bs -> (Just $ fromIntegral $ S.length bs, C.yield $ builder `mappend` fromByteString bs)- RequestBodyBuilder i b -> (Just $ i, C.yield $ builder `mappend` b)- RequestBodySource i source -> (Just i, C.yield builder >> source)- RequestBodySourceChunked source -> (Nothing, C.yield builder >> (source C.$= chunkIt))-- 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"
− Network/HTTP/Conduit/Response.hs
@@ -1,207 +0,0 @@-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE CPP #-}-module Network.HTTP.Conduit.Response- ( Response (..)- , getRedirectedRequest- , getResponse- , lbsResponse- ) where--import Control.Arrow (first)-import Control.Monad (liftM)--import Control.Exception (throwIO)-import Control.Monad.IO.Class (MonadIO, liftIO)--import qualified Data.ByteString as S-import qualified Data.ByteString.Char8 as S8-import qualified Data.ByteString.Lazy as L--import qualified Data.CaseInsensitive as CI--import Data.Default (def)--import Data.Conduit-import Data.Conduit.Internal (ResumableSource (..), Pipe (..))-import qualified Data.Conduit.Zlib as CZ-import qualified Data.Conduit.List as CL--import qualified Network.HTTP.Types as W-import Network.URI (parseURIReference)--import Network.HTTP.Conduit.Types (Response (..), CookieJar)--import Network.HTTP.Conduit.Manager-import Network.HTTP.Conduit.Request-import Network.HTTP.Conduit.Util-import Network.HTTP.Conduit.Chunk-import Network.HTTP.Conduit.Parser (sinkHeaders)--import Data.Void (Void, absurd)--import System.Timeout.Lifted (timeout)-#if MIN_VERSION_conduit(1, 0, 0)-import Data.Conduit.Internal (ConduitM (..))-#endif---- | 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 m -> W.ResponseHeaders -> CookieJar -> Int -> Maybe (Request m)-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 :: Monad m- => Response (ResumableSource m S8.ByteString)- -> m (Response L.ByteString)-lbsResponse res = do- bss <- responseBody res $$+- CL.consume- return res- { responseBody = L.fromChunks bss- }---- | This function can\'t be a Conduit, since it would lose leftovers.-checkHeaderLength :: MonadResource m- => Int- -> Pipe S8.ByteString S8.ByteString Void u m r- -> Pipe S8.ByteString S8.ByteString Void u m r-checkHeaderLength len NeedInput{}- | len <= 0 = liftIO $ throwIO OverlongHeaders-checkHeaderLength len (NeedInput pushI closeI) = NeedInput- (\bs -> checkHeaderLength- (len - S8.length bs)- (pushI bs)) closeI-checkHeaderLength len (PipeM msink) = PipeM (liftM (checkHeaderLength len) msink)-checkHeaderLength _ s@Done{} = s-checkHeaderLength _ (HaveOutput _ _ o) = absurd o-checkHeaderLength len (Leftover p i) = Leftover (checkHeaderLength (len + S.length i) p) i--getResponse :: (MonadResource m, MonadBaseControl IO m)- => ConnRelease m- -> Maybe Int- -> Request m- -> Source m S8.ByteString- -> m (Response (ResumableSource m S8.ByteString))-getResponse connRelease timeout'' req@(Request {..}) src1 = 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- (src2, ((vbs, sc, sm), hs)) <- timeout' $ src1 $$+-#if MIN_VERSION_conduit(1, 0, 0)- ConduitM (checkHeaderLength 4096 $ unConduitM sinkHeaders)-#else- (checkHeaderLength 4096 sinkHeaders)-#endif- let version = if vbs == "1.1" then W.http11 else W.http10- let s = W.Status sc sm- let hs' = map (first CI.mk) hs- let mcl = lookup "content-length" hs' >>= readDec . S8.unpack-- -- should we put this connection back into the connection manager?- let toPut = Just "close" /= lookup "connection" hs' && vbs /= "1.0"- let cleanup bodyConsumed = connRelease $ if toPut && bodyConsumed then Reuse else DontReuse-- -- RFC 2616 section 4.4_1 defines responses that must not include a body- body <-- if hasNoBody method sc || mcl == Just 0- then do- cleanup True- (rsrc, ()) <- return () $$+ return ()- return rsrc- else do- let isChunked = ("transfer-encoding", "chunked") `elem` hs'- src3 =- if isChunked- then fmapResume ($= chunkedConduit rawBody) src2- else- case mcl of- Just len -> fmapResume ($= requireLength len) src2- Nothing -> src2- src4 =- if needsGunzip req hs'- then fmapResume ($= (if isChunked then ungzipChunked else CZ.ungzip)) src3- else src3- return $ addCleanup' cleanup src4-- return $ Response s version hs' body def- where- -- When a body is both chunked and gzipped, we need to flush each chunk- -- immediately to ensure streaming behavior.- ungzipChunked =- CL.concatMap (\x -> [Chunk x, Flush])- =$= CZ.decompressFlush (CZ.WindowBits 31)- =$= awaitForever unChunk- where- unChunk Flush = return ()- unChunk (Chunk x) = yield x- fmapResume f (ResumableSource src m) = ResumableSource (f src) m- addCleanup' f (ResumableSource src m) = ResumableSource (addCleanup f src) (m >> f False)---- | Ensure that the stream has exactly the given length.-requireLength :: MonadIO m => Int -> Conduit S.ByteString m S.ByteString-requireLength total =- loop total- where- loop 0 = return ()- loop i =- await >>= maybe- (liftIO $ throwIO $ ResponseBodyTooShort- (fromIntegral total)- (fromIntegral $ total - i))- go- where- go bs =- case compare i l of- EQ -> yield bs- LT -> do- let (x, y) = S.splitAt i bs- leftover y- yield x- GT -> yield bs >> loop (i - l)- where- l = S.length bs
− Network/HTTP/Conduit/Types.hs
@@ -1,319 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE FlexibleContexts #-}-module Network.HTTP.Conduit.Types- ( Request (..)- , RequestBody (..)- , ContentType- , Proxy (..)- , HttpException (..)- , Response (..)- , ConnRelease- , ConnReuse (..)- , ManagedConn (..)- , Cookie (..)- , CookieJar (..)- ) where--import Data.Int (Int64)-import Data.Word (Word64)-import Data.Typeable (Typeable)--import Blaze.ByteString.Builder--import qualified Data.Conduit as C--import qualified Data.ByteString as S-import qualified Data.ByteString.Lazy as L--import Data.Time.Clock-import Data.Default-import qualified Data.List as DL--import qualified Network.HTTP.Types as W-import qualified Network.Socket as NS-import Network.Socks5 (SocksConf)--import Control.Exception (Exception, SomeException, IOException)--import Data.Certificate.X509 (X509)-import Network.TLS (PrivateKey)-import Network.HTTP.Conduit.ConnInfo (ConnInfo)-import Network.HTTP.Conduit.Util--import Data.Monoid (Monoid(..))--type ContentType = S.ByteString---- | All information on how to connect to a host and what should be sent in the--- HTTP request.------ If you simply wish to download from a URL, see 'parseUrl'.------ The constructor for this data type is not exposed. Instead, you should use--- either the 'def' method to retrieve a default instance, or 'parseUrl' to--- construct from a URL, and then use the records below to make modifications.--- This approach allows http-conduit to add configuration options without--- breaking backwards compatibility.------ For example, to construct a POST request, you could do something like:------ > initReq <- parseUrl "http://www.example.com/path"--- > let req = initReq--- > { method = "POST"--- > }------ For more information, please see--- <http://www.yesodweb.com/book/settings-types>.-data Request m = Request- { method :: W.Method- -- ^ HTTP request method, eg GET, POST.- , secure :: Bool- -- ^ Whether to use HTTPS (ie, SSL).- , clientCertificates :: [(X509, Maybe PrivateKey)]- -- ^ SSL client certificates- , host :: S.ByteString- , port :: Int- , path :: S.ByteString- -- ^ Everything from the host to the query string.- , queryString :: S.ByteString- , requestHeaders :: W.RequestHeaders- -- ^ Custom HTTP request headers- --- -- As already stated in the introduction, the Content-Length and Host- -- headers are set automatically by this module, and shall not be added to- -- requestHeaders.- --- -- Moreover, the Accept-Encoding header is set implicitly to gzip for- -- convenience by default. This behaviour can be overridden if needed, by- -- setting the header explicitly to a different value. In order to omit the- -- Accept-Header altogether, set it to the empty string \"\". If you need an- -- empty Accept-Header (i.e. requesting the identity encoding), set it to a- -- non-empty white-space string, e.g. \" \". See RFC 2616 section 14.3 for- -- details about the semantics of the Accept-Header field. If you request a- -- content-encoding not supported by this module, you will have to decode- -- it yourself (see also the 'decompress' field).- --- -- Note: Multiple header fields with the same field-name will result in- -- multiple header fields being sent and therefore it\'s the responsibility- -- of the client code to ensure that the rules from RFC 2616 section 4.2- -- are honoured.- , requestBody :: RequestBody m- , proxy :: Maybe Proxy- -- ^ Optional HTTP proxy.- , socksProxy :: Maybe SocksConf- -- ^ Optional SOCKS proxy.- , hostAddress :: Maybe NS.HostAddress- -- ^ Optional resolved host address.- --- -- Since 1.8.9- , rawBody :: Bool- -- ^ If @True@, a chunked and\/or gzipped body will not be- -- decoded. Use with caution.- , decompress :: ContentType -> Bool- -- ^ Predicate to specify whether gzipped data should be- -- decompressed on the fly (see 'alwaysDecompress' and- -- 'browserDecompress'). Default: browserDecompress.- , redirectCount :: Int- -- ^ How many redirects to follow when getting a resource. 0 means follow- -- no redirects. Default value: 10.- , checkStatus :: W.Status -> W.ResponseHeaders -> CookieJar -> Maybe SomeException- -- ^ Check the status code. Note that this will run after all redirects are- -- performed. Default: return a @StatusCodeException@ on non-2XX responses.- , responseTimeout :: Maybe Int- -- ^ Number of microseconds to wait for a response. If @Nothing@, will wait- -- indefinitely. Default: 5 seconds.- , getConnectionWrapper :: forall n. (C.MonadResource n, C.MonadBaseControl IO n)- => Maybe Int- -> HttpException- -> n (ConnRelease n, ConnInfo, ManagedConn)- -> n (Maybe Int, (ConnRelease n, ConnInfo, ManagedConn))- -- ^ Wraps the calls for getting new connections. This can be useful for- -- instituting some kind of timeouts. The first argument is the value of- -- @responseTimeout@. Second argument is the exception to be thrown on- -- failure.- --- -- Default: If @responseTimeout@ is @Nothing@, does nothing. Otherwise,- -- institutes timeout, and returns remaining time for @responseTimeout@.- --- -- Since 1.8.8- , cookieJar :: Maybe CookieJar- -- ^ A user-defined cookie jar.- -- If 'Nothing', no cookie handling will take place, \"Cookie\" headers- -- in 'requestHeaders' will be sent raw, and 'responseCookieJar' will be- -- empty.- --- -- Since 1.9.0- }--data ConnReuse = Reuse | DontReuse--type ConnRelease m = ConnReuse -> m ()--data ManagedConn = Fresh | Reused---- | When using one of the--- 'RequestBodySource' \/ 'RequestBodySourceChunked' constructors,--- you must ensure--- that the 'Source' can be called multiple times. Usually this--- is not a problem.------ The 'RequestBodySourceChunked' will send a chunked request--- body, note that not all servers support this. Only use--- 'RequestBodySourceChunked' if you know the server you're--- sending to supports chunked request bodies.-data RequestBody m- = RequestBodyLBS L.ByteString- | RequestBodyBS S.ByteString- | RequestBodyBuilder Int64 Builder- | RequestBodySource Int64 (C.Source m Builder)- | RequestBodySourceChunked (C.Source m Builder)---- | Define a HTTP proxy, consisting of a hostname and port number.--data Proxy = Proxy- { proxyHost :: S.ByteString -- ^ The host name of the HTTP proxy.- , proxyPort :: Int -- ^ The port number of the HTTP proxy.- }- deriving (Show, Read, Eq, Ord, Typeable)--data HttpException = StatusCodeException W.Status W.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- | ResponseBodyTooShort Word64 Word64- -- ^ Expected size/actual size.- --- -- Since 1.9.4- | InvalidChunkHeaders- -- ^- --- -- Since 1.9.4- deriving (Show, Typeable)-instance Exception HttpException---- | A simple representation of the HTTP response created by 'lbsConsumer'.-data Response body = Response- { responseStatus :: W.Status- -- ^ Status code of the response.- , responseVersion :: W.HttpVersion- -- ^ HTTP version used by the server.- , responseHeaders :: W.ResponseHeaders- -- ^ Response headers sent by the server.- , responseBody :: body- -- ^ Response body sent by the server.- , responseCookieJar :: CookieJar- -- ^ Cookies set on the client after interacting with the server. If- -- cookies have been disabled by setting 'cookieJar' to @Nothing@, then- -- this will always be empty.- }- deriving (Show, Eq, Typeable)---- 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---- | Since 1.1.2.-instance Functor Response where- fmap f response = response {responseBody = f (responseBody response)}---- | Since 1.8.7-instance Show (RequestBody m) where- showsPrec d (RequestBodyBS a) =- showParen (d>=11) $ showString "RequestBodyBS " . showsPrec 11 a- showsPrec d (RequestBodyLBS a) =- showParen (d>=11) $ showString "RequestBodyLBS " . showsPrec 11 a- showsPrec d (RequestBodyBuilder l _) =- showParen (d>=11) $ showString "RequestBodyBuilder " . showsPrec 11 l .- showString " " . showString "<Builder>"- showsPrec d (RequestBodySource l _) =- showParen (d>=11) $ showString "RequestBodySource " . showsPrec 11 l .- showString " <Source m Builder>"- showsPrec d (RequestBodySourceChunked _) =- showParen (d>=11) $ showString "RequestBodySource <Source m Builder>"---- | Since 1.8.7-instance Monad m => Monoid (RequestBody m) where- mempty = RequestBodyLBS mempty-- mappend a b =- case (simplify a, simplify b) of- (SBuilder l1 b1, SBuilder l2 b2) -> RequestBodyBuilder (l1 + l2) (b1 <> b2)- (SBuilder l1 b1, SSource l2 s2) -> RequestBodySource (l1 + l2) (C.yield b1 <> s2)- (SSource l1 s1, SBuilder l2 b2) -> RequestBodySource (l1 + l2) (s1 <> C.yield b2)- (SSource l1 s1, SSource l2 s2) -> RequestBodySource (l1 + l2) (s1 <> s2)- (a', b') -> RequestBodySourceChunked (toChunked a' <> toChunked b')--data Simplified m = SBuilder Int64 Builder- | SSource Int64 (C.Source m Builder)- | SChunked (C.Source m Builder)--simplify :: Monad m => RequestBody m -> Simplified m-simplify (RequestBodyBS a) = SBuilder (fromIntegral $ S.length a) (fromByteString a)-simplify (RequestBodyLBS a) = SBuilder (fromIntegral $ L.length a) (fromLazyByteString a)-simplify (RequestBodyBuilder l a) = SBuilder l a-simplify (RequestBodySource l a) = SSource l a-simplify (RequestBodySourceChunked a) = SChunked a--toChunked :: Monad m => Simplified m -> C.Source m Builder-toChunked (SBuilder _ b) = C.yield b-toChunked (SSource _ s) = s-toChunked (SChunked s) = s
− Network/HTTP/Conduit/Util.hs
@@ -1,84 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleContexts #-}-module Network.HTTP.Conduit.Util- ( hGetSome- , (<>)- , readDec- , hasNoBody- , fromStrict- ) where--import Data.Monoid (Monoid, mappend)--import qualified Data.ByteString.Char8 as S8-#if MIN_VERSION_bytestring(0,10,0)-import Data.ByteString.Lazy (fromStrict)-#else-import qualified Data.ByteString.Lazy as L-import qualified Data.ByteString as S-#endif--import qualified Data.Text as T-import qualified Data.Text.Read--#if MIN_VERSION_base(4,3,0)-import Data.ByteString (hGetSome)-#else-import GHC.IO.Handle.Types-import System.IO (hWaitForInput, hIsEOF)-import System.IO.Error (mkIOError, illegalOperationErrorType)---- | Like 'hGet', except that a shorter 'ByteString' may be returned--- if there are not enough bytes immediately available to satisfy the--- whole request. 'hGetSome' only blocks if there is no data--- available, and EOF has not yet been reached.-hGetSome :: Handle -> Int -> IO S.ByteString-hGetSome hh i- | i > 0 = let- loop = do- s <- S.hGetNonBlocking hh i- if not (S.null s)- then return s- else do eof <- hIsEOF hh- if eof then return s- else hWaitForInput hh (-1) >> loop- -- for this to work correctly, the- -- Handle should be in binary mode- -- (see GHC ticket #3808)- in loop- | i == 0 = return S.empty- | otherwise = illegalBufferSize hh "hGetSome" i--illegalBufferSize :: Handle -> String -> Int -> IO a-illegalBufferSize handle fn sz =- ioError (mkIOError illegalOperationErrorType msg (Just handle) Nothing)- --TODO: System.IO uses InvalidArgument here, but it's not exported :-(- where- msg = fn ++ ": illegal ByteString size " ++ showsPrec 9 sz []-#endif--infixr 5 <>-(<>) :: Monoid m => m -> m -> m-(<>) = mappend--readDec :: Integral i => String -> Maybe i-readDec s =- case Data.Text.Read.decimal $ T.pack s of- Right (i, t)- | T.null t -> Just i- _ -> Nothing--hasNoBody :: S8.ByteString -- ^ request method- -> Int -- ^ status code- -> Bool-hasNoBody "HEAD" _ = True-hasNoBody _ 204 = True-hasNoBody _ 304 = True-hasNoBody _ i = 100 <= i && i < 200--#if !MIN_VERSION_bytestring(0,10,0)-{-# INLINE fromStrict #-}-fromStrict :: S.ByteString -> L.ByteString-fromStrict x = L.fromChunks [x]-#endif
+ Network/HTTP/Simple.hs view
@@ -0,0 +1,521 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE OverloadedStrings #-}+-- | Simplified interface for common HTTP client interactions. Tutorial+-- available at+-- <https://haskell-lang.org/library/http-client>+--+-- 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+#ifdef VERSION_aeson+ , httpJSON+ , httpJSONEither+#endif+ , httpSink+ , httpSource+ , withResponse+ -- * Types+ , H.Header+ , H.Query+ , H.QueryItem+ , H.Request+ , H.RequestHeaders+ , H.Response+ , H.ResponseHeaders+#ifdef VERSION_aeson+ , JSONException (..)+#endif+ , 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+#ifdef VERSION_aeson+ , setRequestBodyJSON+#endif+ , setRequestBodyLBS+ , setRequestBodySource+ , setRequestBodyFile+ , setRequestBodyURLEncoded+ -- ** Special fields+ , H.setRequestIgnoreStatus+ , H.setRequestCheckStatus+ , setRequestBasicAuth+#if MIN_VERSION_http_client(0,7,6)+ , setRequestBearerAuth+#endif+ , setRequestManager+ , setRequestProxy+ , setRequestResponseTimeout+ -- * 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)++#ifdef VERSION_aeson+import Data.Aeson (FromJSON (..), Value)+import Data.Aeson.Parser (json')+import qualified Data.Aeson.Types as A+import qualified Data.Aeson as A+#endif++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++#ifdef VERSION_aeson+-- | 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.+--+-- NOTE: Depends on the @aeson@ cabal flag being enabled+--+-- @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.+--+-- NOTE: Depends on the @aeson@ cabal flag being enabled+--+-- @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+--+-- NOTE: Depends on the @aeson@ cabal flag being enabled+--+-- @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+#endif++-- | 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 }++#ifdef VERSION_aeson+-- | 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@+--+-- NOTE: Depends on the @aeson@ cabal flag being enabled+--+-- @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+ }+#endif++-- | 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++#if MIN_VERSION_http_client(0,7,6)+-- | Set bearer auth with the given token+--+-- @since 2.3.8+setRequestBearerAuth :: S.ByteString -- ^ token+ -> H.Request+ -> H.Request+setRequestBearerAuth = H.applyBearerAuth+#endif++-- | 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 }++-- | Set the maximum time to wait for a response+--+-- @since 2.3.8+setRequestResponseTimeout :: H.ResponseTimeout -> H.Request -> H.Request+setRequestResponseTimeout x req = req { H.responseTimeout = 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
+ README.md view
@@ -0,0 +1,10 @@+http-conduit+============++Provides for making efficient HTTP/HTTPS requests, providing either a simple or+streaming interface.++Full tutorial docs are available at:+https://github.com/snoyberg/http-client/blob/master/TUTORIAL.md++The `Network.HTTP.Conduit.Browser` module has been moved to <http://hackage.haskell.org/package/http-conduit-browser/>
+ certificate.pem view
@@ -0,0 +1,15 @@+-----BEGIN CERTIFICATE-----+MIICWDCCAcGgAwIBAgIJAJG1ZMlcMDW6MA0GCSqGSIb3DQEBBQUAMEUxCzAJBgNV+BAYTAkFVMRMwEQYDVQQIDApTb21lLVN0YXRlMSEwHwYDVQQKDBhJbnRlcm5ldCBX+aWRnaXRzIFB0eSBMdGQwHhcNMTExMDIyMTk0MjU3WhcNMTExMTIxMTk0MjU3WjBF+MQswCQYDVQQGEwJBVTETMBEGA1UECAwKU29tZS1TdGF0ZTEhMB8GA1UECgwYSW50+ZXJuZXQgV2lkZ2l0cyBQdHkgTHRkMIGfMA0GCSqGSIb3DQEBAQUAA4GNADCBiQKB+gQCfYZx7kV6ybogMyAf9MINm7Rwin5LKh+TpD1ZkbLgmqFVotQCdthgTK66SPXkx+EXGI27biNzacJhX7Ml7/4o8sp2GslYKUO46DYvgi/nnNX/bzA5cDJSSGK11eQEVs++p0GEZ/6Juhpx/oQwMDMgo0UHkiH8QtKI8ojXnFF2MsLNwIDAQABo1AwTjAdBgNV+HQ4EFgQUaA6FbOj/0VJMb4egNyIDZ/ZNV/YwHwYDVR0jBBgwFoAUaA6FbOj/0VJM+b4egNyIDZ/ZNV/YwDAYDVR0TBAUwAwEB/zANBgkqhkiG9w0BAQUFAAOBgQCTQyOk+D86Z+yzedXjTLI6FT8QugmQne1YQ8P0w37P76z2reagSvNee2e9B1oTHoPeKZMs0+k99oS9yJ/NOQ1Ms90P+q0yBVGxAs/gF65qKgE27YGXzNtNobj/D4OoxcFG+BsORw+VvYSBV4FiVy9RwJsr7AMqkUBcOEPCuJHgTx58w==+-----END CERTIFICATE-----
http-conduit.cabal view
@@ -1,143 +1,98 @@+cabal-version: >= 1.10 name: http-conduit-version: 1.9.6+version: 2.3.9.1 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com> maintainer: Michael Snoyman <michael@snoyman.com> synopsis: HTTP client package with conduit interface and HTTPS support.-description:- This package uses conduit for parsing the actual contents of the HTTP connection. It also provides higher-level functions which allow you to avoid directly dealing with streaming data. See <http://www.yesodweb.com/book/http-conduit> for more information.- .- The @Network.HTTP.Conduit.Browser@ module has been moved to <http://hackage.haskell.org/package/http-conduit-browser/>+description: Hackage documentation generation is not reliable. For up to date documentation, please see: <http://www.stackage.org/package/http-conduit>. category: Web, Conduit stability: Stable-cabal-version: >= 1.8 build-type: Simple-homepage: http://www.yesodweb.com/book/http-conduit+homepage: https://github.com/snoyberg/http-client extra-source-files: test/main.hs , test/CookieTest.hs , multipart-example.bin , nyan.gif--flag network-bytestring- default: False+ , certificate.pem+ , key.pem+ , README.md+ , ChangeLog.md -flag tls_1_1_3- default: True+flag aeson+ manual: True+ description: Enable the dependency on aeson+ default: True library- build-depends: base >= 4 && < 5+ default-language: Haskell2010+ build-depends: base >= 4.10 && < 5+ , attoparsec , bytestring >= 0.9.1.4 , transformers >= 0.2- , failure >= 0.1- , resourcet >= 0.3 && < 0.5- , conduit >= 0.5.5 && < 1.1- , zlib-conduit >= 0.5 && < 1.1- , blaze-builder-conduit >= 0.5- , utf8-string >= 0.3.4- , blaze-builder >= 0.2.1+ , resourcet >= 1.1+ , conduit >= 1.2+ , conduit-extra >= 1.1 , http-types >= 0.7- , mime-types >= 0.1- , cprng-aes >= 0.3- , tls >= 1.1.0- , tls-extra >= 0.5.0- , monad-control >= 0.3- , containers >= 0.2- , certificate >= 1.3- , case-insensitive >= 0.2- , base64-bytestring >= 0.1- , asn1-data >= 0.5.1- , data-default- , text- , transformers-base >= 0.4- , lifted-base >= 0.1- , socks >= 0.4- , time- , cookie >= 0.4- , void >= 0.5.5- , regex-compat+ , http-client >= 0.5.13 && < 0.8+ , http-client-tls >= 0.3 && < 0.4 , mtl- , deepseq- , publicsuffixlist >= 0.0.3 && < 1.0- , array >= 0.3- , random- , filepath- if flag(network-bytestring)- build-depends: network >= 2.2.1 && < 2.2.3- , network-bytestring >= 0.1.3 && < 0.1.4- else- build-depends: network >= 2.3- if flag(tls_1_1_3)- build-depends: tls >= 1.1.3- , cprng-aes >= 0.5.0- else- build-depends: tls < 1.1.3- , cprng-aes < 0.5.0+ , unliftio-core++ if flag(aeson)+ build-depends: aeson >= 0.8+ , attoparsec-aeson >= 2.1++ if !impl(ghc>=7.9)+ build-depends: void >= 0.5.5 exposed-modules: Network.HTTP.Conduit- Network.HTTP.Conduit.Internal- Network.HTTP.Conduit.MultipartFormData- other-modules: Network.HTTP.Conduit.Parser- Network.HTTP.Conduit.ConnInfo- Network.HTTP.Conduit.Request- Network.HTTP.Conduit.Util- Network.HTTP.Conduit.Manager- Network.HTTP.Conduit.Chunk- Network.HTTP.Conduit.Response- Network.HTTP.Conduit.Cookies- Network.HTTP.Conduit.Types+ Network.HTTP.Client.Conduit+ Network.HTTP.Simple ghc-options: -Wall test-suite test- main-is: test/main.hs+ default-language: Haskell2010+ main-is: main.hs+ other-modules: CookieTest type: exitcode-stdio-1.0- hs-source-dirs: ., test+ hs-source-dirs: test ghc-options: -Wall cpp-options: -DDEBUG build-depends: base >= 4 && < 5 , HUnit , hspec >= 1.3+ , data-default+ , crypton-connection+ , warp-tls+ , tls < 1.5 || >= 1.5.2+ , time+ , blaze-builder , bytestring+ , text , transformers- , failure- , conduit- , zlib-conduit- , blaze-builder-conduit+ , conduit >= 1.1 , utf8-string- , blaze-builder- , http-types- , cprng-aes- , tls- , tls-extra- , monad-control- , containers- , certificate , case-insensitive- , base64-bytestring- , asn1-data- , data-default- , text- , transformers-base- , lifted-base- , time- , network- , wai < 2.0- , warp >= 1.3.6- , socks+ , unliftio+ , wai >= 3.0 && < 3.3+ , warp >= 3.0.0.2 && < 3.4+ , wai-conduit , http-types , cookie- , regex-compat- , network-conduit >= 0.6+ , http-client+ , http-conduit+ , conduit-extra+ , streaming-commons+ , temporary , resourcet- , void- , deepseq- , mtl- , publicsuffixlist- , array- , random- , filepath- , mime-types+ , network + if flag(aeson)+ build-depends: aeson+ , attoparsec-aeson >= 2.1+ source-repository head type: git- location: git://github.com/snoyberg/http-conduit.git+ location: git://github.com/snoyberg/http-client.git
+ key.pem view
@@ -0,0 +1,15 @@+-----BEGIN RSA PRIVATE KEY-----+MIICXAIBAAKBgQCfYZx7kV6ybogMyAf9MINm7Rwin5LKh+TpD1ZkbLgmqFVotQCd+thgTK66SPXkxEXGI27biNzacJhX7Ml7/4o8sp2GslYKUO46DYvgi/nnNX/bzA5cD+JSSGK11eQEVs+p0GEZ/6Juhpx/oQwMDMgo0UHkiH8QtKI8ojXnFF2MsLNwIDAQAB+AoGAR8pgAgjo7tZ60ccIUjOX/LSxB6d5J2Eu6wvNjk6qZD9OuWtOa7up/HigmZ63+CDMjQNI2/o6AOrWtEQkPYZNbibuifzg5V517nHGSqkqjoIgesAiwEsoKpeOgGTtM+MM08oHbJ9uOnDnEEnDBiE0iE3jCTDfmwjqDMpUhu9dZ1EAECQQDKVpzSSV3pzMOp+ixNxMpYxzcE+4K9jgM+MlxPBJSQhVrg/cRQWb26cKBi8LdSxF23hQTsFr+8qLwid+Ah2AgUOBAkEAyaaCjrNRCiHRpd6YzWZ6GKkxbUvxSuOKX3N7hDaE2OFzQTv2Li8B+5mrCsXnSZtOG+MBFdHU66UYie1OzDSDKtwJAKMsvkOID0ihbZmpIwDC/wUjHZkLs+eXY14hVvgShY0XPnb7r/nspWlZsr6Xyf/hhIKfr5yFrBMFMNPIJ5qjflgQJAWsyV+YTgxN4S+6BdxapvIQq58ySA3CGeo+Q4BAimibB4oTal4UpdsHZrZDB00toRs9Dlv+jN70pfGkuS+ZIkIvxQJBAKSf5qpXWp4oZcThkieAiMeAhG96xqRPXhPUxq6QF+YG+T4PF1sjlpZwqy7C+2oF3BqLP09mCW7YkH9Jgnl1zDF8=+-----END RSA PRIVATE KEY-----
test/CookieTest.hs view
@@ -1,23 +1,42 @@+{-# OPTIONS_GHC -Wno-orphans #-}+ module CookieTest (cookieTest) where import Prelude hiding (exp) import Test.Hspec import qualified Data.ByteString as BS import Test.HUnit hiding (path)-import Network.HTTP.Conduit.Cookies-import Network.HTTP.Conduit.Types+import Network.HTTP.Client import qualified Network.HTTP.Conduit as HC import Data.ByteString.UTF8 import Data.Monoid-import Data.Maybe import Data.Time.Clock import Data.Time.Calendar import qualified Data.CaseInsensitive as CI import Web.Cookie -default_request :: HC.Request m-default_request = fromJust $ HC.parseUrl "http://www.google.com/"+-- We use these Eq instances here because they make sense and may be added to the library in+-- the future. We do not add them now because they would silently break the old Eq behavior,+-- which was `equivCookie`.+instance Eq Cookie where+ (==) = equalCookie +instance Eq CookieJar where+ (==) = equalCookieJar++instance Eq body => Eq (Response body) where+ resp == resp' = and+ [ responseStatus resp == responseStatus resp'+ , responseVersion resp == responseVersion resp'+ , responseHeaders resp == responseHeaders resp'+ , responseBody resp == responseBody resp'+ , responseCookieJar resp `equivCookieJar` responseCookieJar resp' -- !+ -- , responseClose -- !+ ]++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"@@ -49,109 +68,109 @@ , setCookieSecure = False } -testValidIp :: Test-testValidIp = TestCase $ assertBool "Couldn't parse valid IP address" $+testValidIp :: IO ()+testValidIp = assertBool "Couldn't parse valid IP address" $ isIpAddress $ fromString "1.2.3.4" -testIpNumTooHigh :: Test-testIpNumTooHigh = TestCase $ assertBool "One of the digits in the IP address is too large" $+testIpNumTooHigh :: IO ()+testIpNumTooHigh = assertBool "One of the digits in the IP address is too large" $ not $ isIpAddress $ fromString "501.2.3.4" -testTooManySegmentsInIp :: Test-testTooManySegmentsInIp = TestCase $ assertBool "Too many segments in the ip address" $+testTooManySegmentsInIp :: IO ()+testTooManySegmentsInIp = assertBool "Too many segments in the ip address" $ not $ isIpAddress $ fromString "1.2.3.4.5" -testCharsInIp :: Test-testCharsInIp = TestCase $ assertBool "Chars are not allowed in IP addresses" $+testCharsInIp :: IO ()+testCharsInIp = assertBool "Chars are not allowed in IP addresses" $ not $ isIpAddress $ fromString "1.2a3.4.5" -testDomainMatchesSuccess :: Test-testDomainMatchesSuccess = TestCase $ assertBool "Domains should match" $+testDomainMatchesSuccess :: IO ()+testDomainMatchesSuccess = assertBool "Domains should match" $ domainMatches (fromString "www.google.com") (fromString "google.com") -testSameDomain :: Test-testSameDomain = TestCase $ assertBool "Same domain should match" $+testSameDomain :: IO ()+testSameDomain = assertBool "Same domain should match" $ domainMatches domain domain where domain = fromString "www.google.com" -testSiblingDomain :: Test-testSiblingDomain = TestCase $ assertBool "Sibling domain should not match" $+testSiblingDomain :: IO ()+testSiblingDomain = assertBool "Sibling domain should not match" $ not $ domainMatches (fromString "www.google.com") (fromString "secure.google.com") -testParentDomain :: Test-testParentDomain = TestCase $ assertBool "Parent domain should fail" $+testParentDomain :: IO ()+testParentDomain = assertBool "Parent domain should fail" $ not $ domainMatches (fromString "google.com") (fromString "www.google.com") -testNaiveSuffixDomain :: Test-testNaiveSuffixDomain = TestCase $ assertBool "Naively checking for suffix for domain matching should fail" $+testNaiveSuffixDomain :: IO ()+testNaiveSuffixDomain = assertBool "Naively checking for suffix for domain matching should fail" $ not $ domainMatches (fromString "agoogle.com") (fromString "google.com") -testDefaultPath :: Test-testDefaultPath = TestCase $ assertEqual "Getting default path from a request"+testDefaultPath :: IO ()+testDefaultPath = assertEqual "Getting default path from a request" (fromString "/") (defaultPath default_request) -testShortDefaultPath :: Test-testShortDefaultPath = TestCase $ assertEqual "Getting default path from a short path"+testShortDefaultPath :: IO ()+testShortDefaultPath = assertEqual "Getting default path from a short path" (fromString "/") (defaultPath $ default_request {HC.path = fromString "/search"}) -testPopulatedDefaultPath :: Test-testPopulatedDefaultPath = TestCase $ assertEqual "Getting default path from a request with a path"+testPopulatedDefaultPath :: IO ()+testPopulatedDefaultPath = assertEqual "Getting default path from a request with a path" (fromString "/search") (defaultPath $ default_request {HC.path = fromString "/search/term"}) -testParamsDefaultPath :: Test-testParamsDefaultPath = TestCase $ assertEqual "Getting default path from a request with a path and GET params"+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 :: Test-testDefaultPathEndingInSlash = TestCase $ assertEqual "Getting default path that ends in a slash"+testDefaultPathEndingInSlash :: IO ()+testDefaultPathEndingInSlash = assertEqual "Getting default path that ends in a slash" (fromString "/search/term") (defaultPath $ default_request {HC.path = fromString "/search/term/"}) -testSamePathsMatch :: Test-testSamePathsMatch = TestCase $ assertBool "The same path should match" $+testSamePathsMatch :: IO ()+testSamePathsMatch = assertBool "The same path should match" $ pathMatches path' path' where path' = fromString "/a/path" -testPathSlashAtEnd :: Test-testPathSlashAtEnd = TestCase $ assertBool "Putting the slash at the end should still match paths" $+testPathSlashAtEnd :: IO ()+testPathSlashAtEnd = assertBool "Putting the slash at the end should still match paths" $ pathMatches (fromString "/a/path/to/here") (fromString "/a/path/") -testPathNoSlashAtEnd :: Test-testPathNoSlashAtEnd = TestCase $ assertBool "Not putting the slash at the end should still match paths" $+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 :: Test-testDivergingPaths = TestCase $ assertBool "Diverging paths don't match" $+testDivergingPaths :: IO ()+testDivergingPaths = assertBool "Diverging paths don't match" $ not $ pathMatches (fromString "/a/path/to/here") (fromString "/a/different/path") -testCookieEqualitySuccess :: Test-testCookieEqualitySuccess = TestCase $ assertEqual "The same cookies should be equal"+testCookieEqualitySuccess :: IO ()+testCookieEqualitySuccess = assertEqual "The same cookies should be equal" cookie cookie where cookie = default_cookie -testCookieEqualityResiliance :: Test-testCookieEqualityResiliance = TestCase $ assertEqual "Cookies should still be equal if extra options are changed"- (default_cookie {cookie_persistent = True}) (default_cookie {cookie_host_only = True})+testCookieEqualityResiliance :: IO ()+testCookieEqualityResiliance = assertBool "Cookies should still be equal if extra options are changed" $+ (default_cookie {cookie_persistent = True}) `equivCookie` (default_cookie {cookie_host_only = True}) -testDomainChangesEquality :: Test-testDomainChangesEquality = TestCase $ assertBool "Changing the domain should make cookies not equal" $+testDomainChangesEquality :: IO ()+testDomainChangesEquality = assertBool "Changing the domain should make cookies not equal" $ default_cookie /= (default_cookie {cookie_domain = fromString "/search"}) -testRemoveCookie :: Test-testRemoveCookie = TestCase $ assertEqual "Removing a cookie works"+testRemoveCookie :: IO ()+testRemoveCookie = assertEqual "Removing a cookie works" (Just default_cookie, createCookieJar []) (removeExistingCookieFromCookieJar default_cookie $ createCookieJar [default_cookie]) -testRemoveNonexistantCookie :: Test-testRemoveNonexistantCookie = TestCase $ assertEqual "Removing a nonexistant cookie doesn't work"+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 :: Test-testRemoveCorrectCookie = TestCase $ assertEqual "Removing only the correct 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 :: Test-testEvictExpiredCookies = TestCase $ assertEqual "Evicting expired cookies works"+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)@@ -167,27 +186,27 @@ } middle = UTCTime (ModifiedJulianDay 2) (secondsToDiffTime 0) -testEvictNoCookies :: Test-testEvictNoCookies = TestCase $ assertEqual "Evicting empty cookie jar"+testEvictNoCookies :: IO ()+testEvictNoCookies = assertEqual "Evicting empty cookie jar" (createCookieJar []) (evictExpiredCookies (createCookieJar []) middle) where middle = UTCTime (ModifiedJulianDay 2) (secondsToDiffTime 0) -testComputeCookieStringUpdateLastAccessTime :: Test-testComputeCookieStringUpdateLastAccessTime = TestCase $ assertEqual "Updates last access time upon using cookies"+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 :: Test-testComputeCookieStringHostOnly = TestCase $ assertEqual "Host only cookies should match host exactly"+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 :: Test-testComputeCookieStringHostOnlyFilter = TestCase $ assertEqual "Host only cookies shouldn't match subdomain"+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@@ -195,43 +214,44 @@ } ] -testComputeCookieStringDomainMatching :: Test-testComputeCookieStringDomainMatching = TestCase $ assertEqual "Domain matching works for new requests"+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 :: Test-testComputeCookieStringPathMatching = TestCase $ assertEqual "Path matching works for new requests"+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 :: Test-testComputeCookieStringPathMatchingFails = TestCase $ assertEqual "Path matching fails when it should"+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 :: Test-testComputeCookieStringPathMatchingWithParms = TestCase $ assertEqual "Path matching succeeds when request has GET params"+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 :: Test-testComputeCookieStringSecure = TestCase $ assertEqual "Secure flag filters properly"+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 :: Test-testComputeCookieStringHttpOnly = TestCase $ assertEqual "http-only flag filters properly"+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 :: Test-testComputeCookieStringSort = TestCase $ assertEqual "Sorting works correctly"- (fromString "c1=v1;c3=v3;c4=v4;c2=v2", cookie_jar_out) format_output+testComputeCookieStringSort :: IO ()+testComputeCookieStringSort = do+ assertEqual "Sorting works correctly (computed string)" (fst format_output) (fromString "c1=v1;c3=v3;c4=v4;c2=v2")+ assertBool "Sorting works correctly (remaining jar)" $ (snd format_output) `equivCookieJar` cookie_jar_out where now = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 11) cookie_jar = createCookieJar [ default_cookie { cookie_name = fromString "c1" , cookie_value = fromString "v1"@@ -278,8 +298,8 @@ request = default_request {HC.path = fromString "/all/encompassing/request/path"} format_output = computeCookieString request cookie_jar default_time False -testInsertCookiesIntoRequestWorks :: Test-testInsertCookiesIntoRequestWorks = TestCase $ assertEqual "Inserting cookies works"+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@@ -290,124 +310,124 @@ req' = default_request {HC.requestHeaders = [(CI.mk $ fromString "Cookie", fromString "otherkey=otherval")]} -testReceiveSetCookie :: Test-testReceiveSetCookie = TestCase $ assertEqual "Receiving a Set-Cookie"- (createCookieJar [default_cookie]) (receiveSetCookie default_set_cookie default_request default_time True $ createCookieJar [])+testReceiveSetCookie :: IO ()+testReceiveSetCookie = assertBool "Receiving a Set-Cookie" $+ (createCookieJar [default_cookie]) `equivCookieJar` (receiveSetCookie default_set_cookie default_request default_time True $ createCookieJar []) -testReceiveSetCookieTrailingDot :: Test-testReceiveSetCookieTrailingDot = TestCase $ assertEqual "Receiving a Set-Cookie with a trailing domain dot"+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 :: Test-testReceiveSetCookieLeadingDot = TestCase $ assertEqual "Receiving a Set-Cookie with a leading domain dot"- (createCookieJar [default_cookie]) (receiveSetCookie set_cookie default_request default_time True $ createCookieJar [])+testReceiveSetCookieLeadingDot :: IO ()+testReceiveSetCookieLeadingDot = assertBool "Receiving a Set-Cookie with a leading domain dot" $+ (createCookieJar [default_cookie]) `equivCookieJar` (receiveSetCookie set_cookie default_request default_time True $ createCookieJar []) where set_cookie = default_set_cookie {setCookieDomain = Just $ fromString ".www.google.com"} -testReceiveSetCookieNoDomain :: Test-testReceiveSetCookieNoDomain = TestCase $ assertEqual "Receiving cookie without domain"- (createCookieJar [default_cookie]) (receiveSetCookie set_cookie default_request default_time True $ createCookieJar [])+testReceiveSetCookieNoDomain :: IO ()+testReceiveSetCookieNoDomain = assertBool "Receiving cookie without domain" $+ (createCookieJar [default_cookie]) `equivCookieJar` (receiveSetCookie set_cookie default_request default_time True $ createCookieJar []) where set_cookie = default_set_cookie {setCookieDomain = Nothing} -testReceiveSetCookieEmptyDomain :: Test-testReceiveSetCookieEmptyDomain = TestCase $ assertEqual "Receiving cookie with empty domain"- (createCookieJar [default_cookie]) (receiveSetCookie set_cookie default_request default_time True $ createCookieJar [])+testReceiveSetCookieEmptyDomain :: IO ()+testReceiveSetCookieEmptyDomain = assertBool "Receiving cookie with empty domain" $+ (createCookieJar [default_cookie]) `equivCookieJar` (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 :: Test-testReceiveSetCookieNonMatchingDomain = TestCase $ assertEqual "Receiving cookie with non-matching domain"+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 :: Test-testReceiveSetCookieHostOnly = TestCase $ assertBool "Checking host-only flag gets set" $+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 :: Test-testReceiveSetCookieHostOnlyNotSet = TestCase $ assertBool "Checking host-only flag doesn't get set" $+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 :: Test-testReceiveSetCookieHttpOnly = TestCase $ assertBool "Checking http-only flag gets set" $+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 :: Test-testReceiveSetCookieHttpOnlyNotSet = TestCase $ assertBool "Checking http-only flag doesn't get set" $+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 :: Test-testReceiveSetCookieHttpOnlyDrop = TestCase $ assertEqual "Checking non http request gets dropped"+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 :: Test-testReceiveSetCookieName = TestCase $ assertEqual "Name gets set correctly"+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 :: Test-testReceiveSetCookieValue = TestCase $ assertEqual "Value gets set correctly"+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 :: Test-testReceiveSetCookieExpiry = TestCase $ assertEqual "Expiry gets set correctly"+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 :: Test-testReceiveSetCookieNoMaxAge = TestCase $ assertEqual "Expiry is based on the given value"+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 :: Test-testReceiveSetCookieNoExpiry = TestCase $ assertEqual "Expiry is based on max age"+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 :: Test-testReceiveSetCookieNoExpiryNoMaxAge = TestCase $ assertBool "Expiry is set to a future date" $+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 :: Test-testReceiveSetCookiePath = TestCase $ assertEqual "Path gets set correctly"+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 :: Test-testReceiveSetCookieNoPath = TestCase $ assertEqual "Path gets set correctly when nonexistant"+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 :: Test-testReceiveSetCookieCreationTime = TestCase $ assertEqual "Creation time gets set correctly"+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 :: Test-testReceiveSetCookieAccessTime = TestCase $ assertEqual "Last access time gets set correctly"+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 :: Test-testReceiveSetCookiePersistent = TestCase $ assertBool "Persistent flag gets set correctly" $+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 :: Test-testReceiveSetCookieSecure = TestCase $ assertBool "Secure flag gets set correctly" $+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 :: Test-testReceiveSetCookieMaxAge = TestCase $ assertEqual "Max-Age gets set correctly"+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@@ -415,8 +435,8 @@ now = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 12) total = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 22) -testReceiveSetCookiePreferMaxAge :: Test-testReceiveSetCookiePreferMaxAge = TestCase $ assertEqual "Max-Age is preferred over Expires"+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@@ -425,27 +445,27 @@ now = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 12) total = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 22) -testReceiveSetCookieExisting :: Test-testReceiveSetCookieExisting = TestCase $ assertEqual "Existing cookie gets updated"+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 :: Test-testReceiveSetCookieExistingCreation = TestCase $ assertEqual "Creation time gets updated in existing cookie"+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 :: Test-testReceiveSetCookieExistingHttpOnly = TestCase $ assertEqual "Existing http-only cookie gets dropped"+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 :: Test-testMonoidPreferRecent = TestCase $ assertEqual "Monoid prefers more recent cookies"- (cct $ createCookieJar [c2]) (cct $ createCookieJar [c1] `mappend` createCookieJar [c2])+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@@ -489,7 +509,7 @@ removeTests :: Spec removeTests = do it "Removing a cookie works" testRemoveCookie- it "Removing a nonexistant cookie doesn't work" testRemoveNonexistantCookie+ it "Removing a nonexistent cookie doesn't work" testRemoveNonexistantCookie it "Removing the correct cookie" testRemoveCorrectCookie evictionTests :: Spec@@ -530,7 +550,7 @@ 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 nonexistant" testReceiveSetCookieNoPath+ 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
test/main.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} import Test.Hspec@@ -6,25 +7,31 @@ 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, settingsPort, settingsBeforeMainLoop)+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.Conduit.MultipartFormData+import Network.HTTP.Client.MultipartFormData import Control.Concurrent (forkIO, killThread, putMVar, takeMVar, newEmptyMVar, threadDelay) import Network.HTTP.Types-import Control.Exception.Lifted (try, SomeException, bracket, onException, IOException)+import UnliftIO.Exception (try, SomeException, bracket, onException, IOException) import qualified Data.IORef as I import qualified Control.Exception as E (catch)-import Network.HTTP.Conduit.ConnInfo-import Network (withSocketsDo)-import Network.Socket (sClose)-import qualified Network.BSD+import qualified Network.Socket as NS 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), runResourceT, await)+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)@@ -35,11 +42,19 @@ 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, toByteString)+import Blaze.ByteString.Builder (fromByteString) import System.IO-import Data.Monoid (mconcat) import Data.Time.Clock import Data.Time.Calendar+import qualified Network.Wai.Handler.WarpTLS as WT+import Network.Connection (settingDisableCertificateValidation)+import Data.Default (def)+#ifdef VERSION_aeson+import qualified Data.Aeson as A+#endif+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)@@ -64,7 +79,7 @@ cookie_jar :: CookieJar cookie_jar = createCookieJar [cookie] -app :: Application+app :: Wai.Request -> IO Wai.Response app req = case pathInfo req of [] ->@@ -82,7 +97,7 @@ [(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+ ["delayed"] -> return $ responseSource status200 [("foo", "bar")] $ do yield Flush liftIO $ threadDelay 30000000 yield $ Chunk $ fromByteString "Hello World!"@@ -92,34 +107,65 @@ nextPort :: I.IORef Int nextPort = unsafePerformIO $ I.newIORef 15452+{-# NOINLINE nextPort #-} getPort :: IO Int getPort = do- port <- I.atomicModifyIORef nextPort $ \p -> (p + 1, p)- esocket <- try $ bindPort port HostIPv4+ port <- I.atomicModifyIORef nextPort $ \p -> (p + 1, p + 1)+ esocket <- try $ bindPort port "*4" case esocket of Left (_ :: IOException) -> getPort Right socket -> do- sClose socket+ NS.close socket return port -withApp :: Application -> (Int -> IO ()) -> IO ()+withApp :: (Wai.Request -> IO Wai.Response) -> (Int -> IO ()) -> IO () withApp app' f = withApp' (const app') f -withApp' :: (Int -> Application) -> (Int -> IO ()) -> IO ()-withApp' app' f = do+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 defaultSettings- { settingsPort = port- , settingsBeforeMainLoop = putMVar baton ()- } (app' port) `onException` putMVar baton ())+ (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 = withSocketsDo $ do+main = do mapM_ (`hSetBuffering` LineBuffering) [stdout, stderr] hspec $ do cookieTest@@ -130,173 +176,197 @@ 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 (_ :: SomeException) -> return ()- Right _ -> error "Expected an exception"+ Left (HttpExceptionRequest _ StatusCodeException {}) -> return ()+ _ -> error "Expected an exception" describe "httpLbs" $ do it "preserves 'set-cookie' headers" $ withApp app $ \port -> do- request <- parseUrl $ concat ["http://127.0.0.1:", show port, "/cookies"]- withManager $ \manager -> do- response <- httpLbs request manager- let setCookie = mk (fromString "Set-Cookie")- (setCookieHeaders, _) = partition ((== setCookie) . fst) (responseHeaders response)- liftIO $ assertBool "response contains a 'set-cookie' header" $ length setCookieHeaders > 0+ 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 <- parseUrl $ concat ["http://127.0.0.1:", show port, "/cookie_redir1"]- withManager $ \manager -> do- response <- httpLbs request manager- liftIO $ (responseBody response) @?= "nom-nom-nom"+ 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 <- parseUrl $ concat ["http://127.0.0.1:", show port, "/dump_cookies"]- withManager $ \manager -> do- response <- httpLbs (request {redirectCount = 1, cookieJar = Just cookie_jar}) manager- liftIO $ (responseBody response) @?= "key=value"+ 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 <- parseUrl $ concat ["http://127.0.0.1:", show port, "/dump_cookies"]- withManager $ \manager -> do- response <- httpLbs (request {redirectCount = 0, cookieJar = Just cookie_jar}) manager- liftIO $ (responseBody response) @?= "key=value"+ 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 <- parseUrl $ concat ["http://127.0.0.1:", show port, "/cookies"]- withManager $ \manager -> do- response <- httpLbs (request {cookieJar = Just def}) manager- liftIO $ (length $ destroyCookieJar $ responseCookieJar response) @?= 1+ 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 <- parseUrl $ concat ["http://127.0.0.1:", show port, "/dump_cookies"]- withManager $ \manager -> do- let request_headers = (mk "Cookie", "key2=value2") : filter ((/= mk "Cookie") . fst) (NHC.requestHeaders request)- response <- httpLbs (request {NHC.requestHeaders = request_headers, cookieJar = Nothing}) manager- liftIO $ (responseBody response) @?= "key2=value2"+ 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 <- parseUrl $ concat ["http://127.0.0.1:", show port, "/cookies"]- withManager $ \manager -> do- response <- httpLbs (request {cookieJar = Nothing}) manager- liftIO $ (responseCookieJar response) @?= def+ 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- clearSocketsList- withManager $ \manager -> do- let Just req1 = parseUrl $ "http://127.0.0.1:" ++ show port1- let Just req2 = parseUrl $ "http://127.0.0.1:" ++ show port2+ --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 ()- requireAllSocketsClosed+ --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- withManager $ \manager -> do- let Just req1 = parseUrl $ "http://127.0.0.1:" ++ show port- res1 <- try $ http req1 manager- case res1 of- Left e -> liftIO $ show (e :: SomeException) @?= show OverlongHeaders- _ -> error "Shouldn't have worked"+ 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- withManager $ \manager -> do- let Just req1 = parseUrl $ "http://127.0.0.1:" ++ show port- _ <- httpLbs req1 manager- return ()+ 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- withManager $ \manager -> do- let go (encoded, final) = do- let Just req1 = parseUrl $ 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?#")- ]+ 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 = parseUrl $ concat ["http://127.0.0.1:", show port, "/infredir/0"]+ 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)- E.catch (withManager $ \manager -> do- void $ http req{redirectCount=5} manager) $- \(TooManyRedirects redirs) -> mapM_ go (zip redirs [5,4..0 :: Int])+ 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- withManager $ \manager -> do- let go bss = do- let Just req1 = parseUrl $ "http://127.0.0.1:" ++ show port- src = sourceList $ map fromByteString bss- lbs = L.fromChunks bss- res <- httpLbs req1- { method = "POST"- , 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"- ]+ 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 <- parseUrl $ "http://127.0.0.1:" ++ show port- withManager $ \manager -> do- res <- httpLbs req manager- liftIO $ do- Network.HTTP.Conduit.responseStatus res `shouldBe` status200- responseBody res `shouldBe` "foo"+ 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 <- parseUrl $ "http://127.0.0.1:" ++ show port- withManager $ \manager -> do- eres <- try $ httpLbs req manager- liftIO $ either (Left . (show :: HttpException -> String)) (Right . id) eres- `shouldBe` Left (show $ ResponseBodyTooShort 50 18)+ 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 <- parseUrl $ "http://127.0.0.1:" ++ show port- withManager $ \manager -> do- eres <- try $ httpLbs req manager- liftIO $ either (Left . (show :: HttpException -> String)) (Right . id) eres- `shouldBe` Left (show InvalidChunkHeaders)+ 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 <- parseUrl $ "http://127.0.0.1:" ++ show port- withManager $ \manager -> do- eres <- try $ httpLbs req manager- liftIO $ either (Left . (show :: HttpException -> String)) (Right . id) eres- `shouldBe` Left (show InvalidChunkHeaders)+ 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 <- parseUrl $ "http://127.0.0.1:" ++ show port- withManager $ \manager -> do- eres <- try $ httpLbs req manager- liftIO $ either (Left . (show :: HttpException -> String)) (Right . id) eres- `shouldBe` Left (show InvalidChunkHeaders)+ 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 <- parseUrl $ "http://127.0.0.1:" ++ show port- withManager $ \manager -> do- eres <- try $ httpLbs req manager- liftIO $ either (Left . (show :: HttpException -> String)) (Right . id) eres- `shouldBe` Left (show InvalidChunkHeaders)+ 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 <- parseUrl $ "http://127.0.0.1:" ++ show port- withManager $ \manager -> do- eres <- try $ httpLbs req manager- liftIO $ either (Left . (show :: HttpException -> String)) (Right . id) eres- `shouldBe` Left (show InvalidChunkHeaders)+ 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"- withApp' app' $ \port -> withManager $ \manager -> do- req <- parseUrl $ "http://127.0.0.1:" ++ show port+ _ -> 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@@ -304,7 +374,7 @@ describe "multipart/form-data" $ do it "formats correctly" $ do let bd = "---------------------------190723902820679116301912680260"- (RequestBodySource _ src) <- renderParts bd+ (RequestBodyStream _ givesPopper) <- renderParts bd [partBS "email" "" ,partBS "parent_id" "70488" ,partBS "captcha" ""@@ -312,55 +382,131 @@ ,partBS "text" $ TE.encodeUtf8 ">>72127\r\nМы работаем над этим." ,partFileSource "upload" "nyan.gif" ]- mfd <- fmap (toByteString . mconcat) $ runResourceT $ src $$ CL.consume+ 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- _ <- appSource app' $$ await- yield "HTTP/1.0 200 OK\r\n\r\nThis is it!" $$ appSink app'- withCApp baseHTTP $ \port -> withManager $ \manager -> do- req <- parseUrl $ "http://127.0.0.1:" ++ show port+ _ <- 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' <- parseUrl $ "http://example.com:" ++ show port- let req = req' { hostAddress = Just $ Network.BSD.hostAddress entry }- res <- withManager $ httpLbs req+ req' <- parseUrlThrow $ "http://example.com:" ++ show port+ let req = req' { hostAddress = Just $ NS.tupleToHostAddress (127, 0, 0, 1) }+ manager <- newManager tlsManagerSettings+ res <- httpLbs req manager responseBody res @?= "homepage for example.com" describe "managerResponseTimeout" $ do it "works" $ withApp app $ \port -> do- req1 <- parseUrl $ "http://localhost:" ++ show port- let req2 = req1 { responseTimeout = Just 5000000 }- withManagerSettings def { managerResponseTimeout = Just 1 } $ \man -> do- eres1 <- try $ httpLbs req1 { NHC.path = "/delayed" } man- case eres1 of- Left (FailedConnectionException _ _) -> return ()- _ -> error "Did not time out"- _ <- httpLbs req2 man- return ()+ 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 <- parseUrl $ "http://localhost:" ++ show port ++ "/delayed"- withManager $ \man -> do- _ <- http req man- return ()+ req <- parseUrlThrow $ "http://localhost:" ++ show port ++ "/delayed"+ man <- newManager tlsManagerSettings+ _ <- runResourceT $ http req man+ return () -withCApp :: Data.Conduit.Network.Application IO -> (Int -> IO ()) -> IO ()+ 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++#ifdef VERSION_aeson+ 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+#endif++ 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 HostAny :: ServerSettings IO) { serverAfterBind = const start }+ settings = (serverSettings port "*" :: ServerSettings IO) { serverAfterBind = const start }+#endif bracket (forkIO $ runTCPServer settings app' `onException` start) killThread@@ -368,14 +514,14 @@ overLongHeaders :: (Int -> IO ()) -> IO () overLongHeaders =- withCApp $ \app' -> src $$ appSink app'+ 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- appSource app' $$ CL.drop 1- src $$ appSink app'+ 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")] @@ -415,20 +561,20 @@ echo :: (Int -> IO ()) -> IO () echo = withApp $ \req -> do- bss <- Wai.requestBody req $$ CL.consume+ bss <- runConduit $ sourceRequestBody req .| CL.consume return $ responseLBS status200 [] $ L.fromChunks bss noStatusMessage :: (Int -> IO ()) -> IO () noStatusMessage =- withCApp $ \app' -> src $$ appSink app'+ 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- _ <- appSource app' $$ await- src $$ appSink app'+ _ <- 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"@@ -437,31 +583,49 @@ wrongLengthChunk1 :: (Int -> IO ()) -> IO () wrongLengthChunk1 = withCApp $ \app' -> do- _ <- appSource app' $$ await- src $$ appSink app'+ _ <- 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- _ <- appSource app' $$ await- src $$ appSink app'+ _ <- 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- _ <- appSource app' $$ await- src $$ appSink app'+ _ <- 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- _ <- appSource app' $$ await- src $$ appSink app'+ _ <- runConduit $ appSource app' .| await+ runConduit $ src .| appSink app' where src = yield bs++#ifdef VERSION_aeson+jsonApp :: (Int -> IO ()) -> IO ()+jsonApp = withApp $ \req -> return $ responseLBS+ status200+ [ ("Content-Type", "application/json")+ ] $+ case pathInfo req of+ [] -> A.encode jsonValue+ ["trailing"] -> L.append (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)+ ]+#endif