http-conduit 1.4.1.10 → 2.3.9.1
raw patch · 22 files changed
Files
- ChangeLog.md +155/−0
- Network/HTTP/Client/Conduit.hs +192/−0
- Network/HTTP/Conduit.hs +238/−153
- Network/HTTP/Conduit/Browser.hs +0/−195
- Network/HTTP/Conduit/Chunk.hs +0/−81
- Network/HTTP/Conduit/ConnInfo.hs +0/−175
- Network/HTTP/Conduit/Cookies.hs +0/−266
- Network/HTTP/Conduit/Internal.hs +0/−5
- Network/HTTP/Conduit/Manager.hs +0/−438
- Network/HTTP/Conduit/Parser.hs +0/−122
- Network/HTTP/Conduit/Request.hs +0/−349
- Network/HTTP/Conduit/Response.hs +0/−154
- Network/HTTP/Conduit/Util.hs +0/−71
- Network/HTTP/Simple.hs +521/−0
- README.md +10/−0
- certificate.pem +15/−0
- http-conduit.cabal +64/−88
- key.pem +15/−0
- multipart-example.bin binary
- nyan.gif binary
- test/CookieTest.hs +580/−0
- test/main.hs +553/−113
+ 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,7 +1,20 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE CPP #-}--- | 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:@@ -15,41 +28,78 @@ -- 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--- > Response _ _ _ src <- http request manager--- > src C.$$ sinkFile "google.html"+-- > request <- parseRequest "http://google.com/"+-- > manager <- newManager tlsManagerSettings+-- > runResourceT $ do+-- > response <- http request manager+-- > runConduit $ responseBody response .| sinkFile "google.html" -- -- The following headers are automatically set by this module, and should not -- be added to 'requestHeaders': --+-- * Cookie+-- -- * Content-Length ----- * Host+-- * Transfer-Encoding ----- * Accept-Encoding (not currently set, but client usage of this variable /will/ cause breakage).+-- Note: In previous versions, the Host header would be set by this module in+-- all cases. Starting from 1.6.1, if a Host header is present in+-- @requestHeaders@, it will be used in place of the header this module would+-- have generated. This can be useful for calling a server which utilizes+-- virtual hosting. ----- 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:+-- Use `cookieJar` If you want to supply cookies with your request: --+-- > {-# LANGUAGE OverloadedStrings #-} -- > import Network.HTTP.Conduit--- > import qualified Data.ByteString.Lazy as L--- > import Network (withSocketsDo)+-- > import Network+-- > import Data.Time.Clock+-- > import Data.Time.Calendar+-- > import qualified Control.Exception as E+-- > import Network.HTTP.Types.Status (statusCode) -- >--- > main = withSocketsDo--- > $ simpleHttp "http://www.haskell.org/" >>= L.putStr+-- > past :: UTCTime+-- > past = UTCTime (ModifiedJulianDay 56200) (secondsToDiffTime 0) -- >--- > Cookies are implemented according to RFC 6265.+-- > future :: UTCTime+-- > future = UTCTime (ModifiedJulianDay 562000) (secondsToDiffTime 0)+-- >+-- > cookie :: Cookie+-- > cookie = Cookie { cookie_name = "password_hash"+-- > , cookie_value = "abf472c35f8297fbcabf2911230001234fd2"+-- > , cookie_expiry_time = future+-- > , cookie_domain = "example.com"+-- > , cookie_path = "/"+-- > , cookie_creation_time = past+-- > , cookie_last_access_time = past+-- > , cookie_persistent = False+-- > , cookie_host_only = False+-- > , cookie_secure_only = False+-- > , cookie_http_only = False+-- > }+-- >+-- > main = do+-- > request' <- parseRequest "http://example.com/secret-page"+-- > manager <- newManager tlsManagerSettings+-- > let request = request' { cookieJar = Just $ createCookieJar [cookie] }+-- > fmap Just (httpLbs request manager) `E.catch`+-- > (\ex -> case ex of+-- > HttpExceptionRequest _ (StatusCodeException res _) ->+-- > if statusCode (responseStatus res) == 403+-- > then (putStrLn "login failed" >> return Nothing)+-- > else return Nothing+-- > _ -> E.throw ex) --+-- Cookies are implemented according to RFC 6265.+-- -- Note that by default, the functions in this package will throw exceptions -- for non-2xx status codes. If you would like to avoid this, you should use -- 'checkStatus', e.g.:@@ -60,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@@ -73,10 +144,8 @@ -- * Datatypes , Proxy (..) , RequestBody (..)- , Response (..) -- ** Request , Request- , def , method , secure , host@@ -86,36 +155,58 @@ , requestHeaders , requestBody , proxy- , socksProxy+ , hostAddress , rawBody , decompress , redirectCount- , checkStatus+#if MIN_VERSION_http_client(0,6,2)+ , shouldStripHeaderOnRedirect+#endif+ , checkResponse+ , responseTimeout+ , cookieJar+ , requestVersion+ , HCC.setQueryString+ -- *** Request body+ , requestBodySource+ , requestBodySourceChunked+ , requestBodySourceIO+ , requestBodySourceChunkedIO+ -- * Response+ , Response+ , responseStatus+ , responseVersion+ , responseHeaders+ , responseBody+ , responseCookieJar+ , responseEarlyHints -- * Manager , Manager , newManager , closeManager- , withManager -- ** Settings , ManagerSettings+ , tlsManagerSettings+ , mkManagerSettings , managerConnCount- , managerCheckCerts- -- *** Defaults- , defaultCheckCerts+ , managerResponseTimeout+ , managerTlsConnection+ -- ** Response timeout+ , HC.ResponseTimeout+ , HC.responseTimeoutMicro+ , HC.responseTimeoutNone+ , HC.responseTimeoutDefault -- * Cookies , Cookie(..) , CookieJar , createCookieJar , destroyCookieJar- , updateCookieJar- , receiveSetCookie- , generateCookie- , insertCheckedCookie- , insertCookiesIntoRequest- , computeCookieString- , evictExpiredCookies -- * Utility functions , parseUrl+ , parseUrlThrow+ , parseRequest+ , parseRequest_+ , defaultRequest , applyBasicAuth , addProxy , lbsResponse@@ -124,115 +215,43 @@ , alwaysDecompress , browserDecompress -- * Request bodies+ -- | "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)-import Control.Monad.IO.Class (MonadIO (liftIO))-import Control.Monad.Trans.Control (MonadBaseControl)--import qualified Data.Conduit as C-import qualified Data.Conduit.Internal as CI-import Data.Conduit.Blaze (builderToByteString)-import Data.Conduit (MonadResource)-import Control.Exception.Lifted (try, SomeException)--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---- | 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.------ 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.Source m S.ByteString))-http req0 manager = do- res@(Response status _version hs body) <-- if redirectCount req0 == 0- then httpRaw req0 manager- else go (redirectCount req0) req0 def- case checkStatus req0 status hs of- Nothing -> return res- Just exc -> do- CI.runFinalize $ CI.pipeClose body- liftIO $ throwIO exc- where- go 0 _ _ = liftIO $ throwIO TooManyRedirects- go count req'' cookie_jar'' = do- now <- liftIO getCurrentTime- let (req', cookie_jar') = insertCookiesIntoRequest req'' (evictExpiredCookies cookie_jar'' now) now- res <- httpRaw req' manager- let (cookie_jar, _) = updateCookieJar res req' now cookie_jar'- case getRedirectedRequest req' (responseHeaders res) (W.statusCode (responseStatus res)) of- Just req -> go (count - 1) req cookie_jar- Nothing -> return res---- | Get a 'Response' without any redirect following.-httpRaw- :: (MonadBaseControl IO m, MonadResource m)- => Request m- -> Manager- -> m (Response (C.Source m S.ByteString))-httpRaw req m = do- (connRelease, ci, isManaged) <- 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 req src+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 - case (ex, isManaged) of- -- Connection was reused, and might be been closed. Try again- (Left _, Reused) -> do- connRelease DontReuse- http req m- -- Not reused, so this is a real exception- (Left e, Fresh) -> 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 x, _) -> return x- where- try' :: MonadBaseControl IO m => m a -> m (Either SomeException a)- try' = try+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'. --@@ -241,7 +260,7 @@ -- interleaved actions on the response body during download, you'll need to use -- 'http' directly. This function is defined as: ----- @httpLbs = 'lbsResponse' . 'http'@+-- @httpLbs = 'lbsResponse' <=< 'http'@ -- -- Even though the 'Response' contains a lazy bytestring, this -- function does /not/ utilize lazy I/O, and therefore the entire@@ -249,25 +268,91 @@ -- 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 = lbsResponse . http r+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--- input. This function essentially wraps 'httpLbsRedirect'.+-- to a limit of 10 redirects). It uses 'parseUrlThrow' to parse the+-- input. This function essentially wraps 'httpLbs'. -- -- Note: Even though this function returns a lazy bytestring, it -- does /not/ utilize lazy I/O, and therefore the entire response -- body will live in memory. If you want constant memory usage,--- you'll need to use the @conduit@ package and 'http' or--- 'httpRedirect' directly.+-- you'll need to use the @conduit@ package and 'http' directly.+--+-- Note: This function creates a new 'Manager'. It should be avoided+-- in production code. simpleHttp :: MonadIO m => String -> m L.ByteString-simpleHttp url = liftIO $ withManager $ \man -> do- url' <- liftIO $ parseUrl url- fmap responseBody $ httpLbs url' man+simpleHttp url = liftIO $ do+ man <- newManager tlsManagerSettings+ req <- liftIO $ parseUrlThrow url+ responseBody A.<$> httpLbs (setConnectionClose req) man++setConnectionClose :: Request -> Request+setConnectionClose req = req{requestHeaders = ("Connection", "close") : requestHeaders req}++lbsResponse :: Monad m+ => Response (ConduitM () S.ByteString m ())+ -> m (Response L.ByteString)+lbsResponse res = do+ bss <- runConduit $ responseBody res .| CL.consume+ return res+ { responseBody = L.fromChunks bss+ }++http :: MonadResource m+ => Request+ -> Manager+ -> m (Response (ConduitM i S.ByteString m ()))+http req man = 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/Browser.hs
@@ -1,195 +0,0 @@-module Network.HTTP.Conduit.Browser- ( BrowserState- , BrowserAction- , browse- , makeRequest- , defaultState- , getBrowserState- , setBrowserState- , withBrowserState- , getMaxRedirects - , setMaxRedirects - , getMaxRetryCount- , setMaxRetryCount- , getAuthorities - , setAuthorities - , getCookieFilter - , setCookieFilter - , getCookieJar - , setCookieJar - , getCurrentProxy - , setCurrentProxy - , getUserAgent - , setUserAgent - , getManager - , setManager- )- where--import qualified Data.ByteString as BS-import Control.Monad.State-import Control.Exception-import qualified Control.Exception.Lifted as LE-import Data.Conduit-import Prelude hiding (catch)-import qualified Network.HTTP.Types as HT-import Data.Time.Clock (getCurrentTime, UTCTime)-import Data.CaseInsensitive (mk)-import Data.ByteString.UTF8 (fromString)-import Data.List (partition)-import Web.Cookie (parseSetCookie)-import Data.Default (def)-import Data.Maybe (catMaybes)--import Network.HTTP.Conduit.Cookies hiding (updateCookieJar)-import Network.HTTP.Conduit.Request-import Network.HTTP.Conduit.Response-import Network.HTTP.Conduit.Manager-import qualified Network.HTTP.Conduit as HC--data BrowserState = BrowserState- { maxRedirects :: Int- , maxRetryCount :: Int- , authorities :: Request (ResourceT IO) -> Maybe (BS.ByteString, BS.ByteString)- , cookieFilter :: Request (ResourceT IO) -> Cookie -> IO Bool- , cookieJar :: CookieJar- , currentProxy :: Maybe Proxy- , userAgent :: BS.ByteString- , manager :: Manager- } --defaultState :: Manager -> BrowserState-defaultState m = BrowserState { maxRedirects = 10- , maxRetryCount = 1- , authorities = \ _ -> Nothing- , cookieFilter = \ _ _ -> return True- , cookieJar = def- , currentProxy = Nothing- , userAgent = fromString "http-conduit"- , manager = m- }--type BrowserAction = StateT BrowserState (ResourceT IO)---- | Do the browser action with the given manager-browse :: Manager -> BrowserAction a -> ResourceT IO a-browse m act = evalStateT act (defaultState m)---- | Make a request, using all the state in the current BrowserState-makeRequest :: Request (ResourceT IO) -> BrowserAction (Response (Source (ResourceT IO) BS.ByteString))-makeRequest request = do- BrowserState- { maxRetryCount = max_retry_count- , currentProxy = current_proxy- , userAgent = user_agent- } <- get- retryHelper (applyUserAgent user_agent $- request { redirectCount = 0- , proxy = current_proxy- , checkStatus = \ _ _ -> Nothing- }) max_retry_count Nothing- where retryHelper request' retry_count e- | retry_count == 0 = case e of- Just e' -> throw e'- Nothing -> throw TooManyRedirects- | otherwise = do- BrowserState {maxRedirects = max_redirects} <- get- resp <- LE.catch (runRedirectionChain request' max_redirects)- (\ e' -> retryHelper request' (retry_count - 1) (Just (e' :: HttpException)))- let code = HT.statusCode $ HC.responseStatus resp- if code < 200 || code >= 300- then retryHelper request' (retry_count - 1) (Just $ HC.StatusCodeException (HC.responseStatus resp) (HC.responseHeaders resp))- else return resp- runRedirectionChain request' redirect_count- | redirect_count == 0 = throw TooManyRedirects- | otherwise = do- s@(BrowserState { manager = manager'- , authorities = auths- , cookieJar = cookie_jar- , cookieFilter = cookie_filter- }) <- get- now <- liftIO getCurrentTime- let (request'', cookie_jar') = insertCookiesIntoRequest- (applyAuthorities auths request')- (evictExpiredCookies cookie_jar now) now- res <- lift $ HC.http request'' manager'- (cookie_jar'', response) <- liftIO $ updateCookieJar res request'' now cookie_jar' cookie_filter- put $ s {cookieJar = cookie_jar''}- let code = HT.statusCode (HC.responseStatus response)- if code >= 300 && code < 400- then runRedirectionChain (case HC.getRedirectedRequest request'' (responseHeaders response) code of- Just a -> a- Nothing -> throw HC.UnparseableRedirect) (redirect_count - 1)- else return res- applyAuthorities auths request' = case auths request' of- Just (user, pass) -> applyBasicAuth user pass request'- Nothing -> request'- applyUserAgent ua request' = request' {requestHeaders = (k, ua) : hs}- where hs = filter ((/= k) . fst) $ requestHeaders request'- k = mk $ fromString "User-Agent"--updateCookieJar :: Response a -> Request (ResourceT IO) -> UTCTime -> CookieJar -> (Request (ResourceT IO) -> Cookie -> IO Bool) -> IO (CookieJar, Response a)-updateCookieJar response request' now cookie_jar cookie_filter = do- filtered_cookies <- filterM (cookie_filter request') $ catMaybes $ map (\ sc -> generateCookie sc request' now True) set_cookies- return (cookieJar' filtered_cookies, response {HC.responseHeaders = other_headers})- where (set_cookie_headers, other_headers) = partition ((== (mk $ fromString "Set-Cookie")) . fst) $ HC.responseHeaders response- set_cookie_data = map snd set_cookie_headers- set_cookies = map parseSetCookie set_cookie_data- cookieJar' = foldl (\ cj c -> insertCheckedCookie c cj True) cookie_jar---- | You can save and restore the state at will-getBrowserState :: BrowserAction BrowserState-getBrowserState = get-setBrowserState :: BrowserState -> BrowserAction ()-setBrowserState = put-withBrowserState :: BrowserState -> BrowserAction a -> BrowserAction a-withBrowserState s a = do- current <- get- put s- out <- a- put current- return out---- | The number of redirects to allow-getMaxRedirects :: BrowserAction Int-getMaxRedirects = get >>= \ a -> return $ maxRedirects a-setMaxRedirects :: Int -> BrowserAction ()-setMaxRedirects b = get >>= \ a -> put a {maxRedirects = b}--- | The number of times to retry a failed connection-getMaxRetryCount :: BrowserAction Int-getMaxRetryCount = get >>= \ a -> return $ maxRetryCount a-setMaxRetryCount :: Int -> BrowserAction ()-setMaxRetryCount b = get >>= \ a -> put a {maxRetryCount = b}--- | A user-provided function that provides optional authorities.--- This function gets run on all requests before they get sent out.--- The output of this function is applied to the request.-getAuthorities :: BrowserAction (Request (ResourceT IO) -> Maybe (BS.ByteString, BS.ByteString))-getAuthorities = get >>= \ a -> return $ authorities a-setAuthorities :: (Request (ResourceT IO) -> Maybe (BS.ByteString, BS.ByteString)) -> BrowserAction ()-setAuthorities b = get >>= \ a -> put a {authorities = b}--- | Each new Set-Cookie the browser encounters will pass through this filter.--- Only cookies that pass the filter (and are already valid) will be allowed into the cookie jar-getCookieFilter :: BrowserAction (Request (ResourceT IO) -> Cookie -> IO Bool)-getCookieFilter = get >>= \ a -> return $ cookieFilter a-setCookieFilter :: (Request (ResourceT IO) -> Cookie -> IO Bool) -> BrowserAction ()-setCookieFilter b = get >>= \ a -> put a {cookieFilter = b}--- | All the cookies!-getCookieJar :: BrowserAction CookieJar-getCookieJar = get >>= \ a -> return $ cookieJar a-setCookieJar :: CookieJar -> BrowserAction ()-setCookieJar b = get >>= \ a -> put a {cookieJar = b}--- | An optional proxy to send all requests through-getCurrentProxy :: BrowserAction (Maybe Proxy)-getCurrentProxy = get >>= \ a -> return $ currentProxy a-setCurrentProxy :: Maybe Proxy -> BrowserAction ()-setCurrentProxy b = get >>= \ a -> put a {currentProxy = b}--- | What string to report our user-agent as-getUserAgent :: BrowserAction BS.ByteString-getUserAgent = get >>= \ a -> return $ userAgent a-setUserAgent :: BS.ByteString -> BrowserAction ()-setUserAgent b = get >>= \ a -> put a {userAgent = b}--- | The active manager, managing the connection pool-getManager :: BrowserAction Manager-getManager = get >>= \ a -> return $ manager a-setManager :: Manager -> BrowserAction ()-setManager b = get >>= \ a -> put a {manager = b}
− Network/HTTP/Conduit/Chunk.hs
@@ -1,81 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-module Network.HTTP.Conduit.Chunk- ( chunkedConduit- , chunkIt- ) where--import Control.Exception (assert)-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 qualified Data.Attoparsec.ByteString as A--import qualified Data.Conduit as C-import Data.Conduit.Attoparsec (ParseError (ParseError))--import Network.HTTP.Conduit.Parser---data CState = NeedHeader (S.ByteString -> A.Result Int)- | Isolate Int- | NeedNewline (S.ByteString -> A.Result ())- | Complete--chunkedConduit :: C.MonadThrow m- => Bool -- ^ send the headers as well, necessary for a proxy- -> C.Conduit S.ByteString m S.ByteString-chunkedConduit sendHeaders = C.conduitState- (NeedHeader $ A.parse parseChunkHeader)- (push id)- close- where- push front (NeedHeader f) x =- case f x of- A.Done x' i- | i == 0 -> push front Complete x'- | otherwise -> do- let header = S8.pack $ showHex i "\r\n"- let addHeader = if sendHeaders then (header:) else id- push (front . addHeader) (Isolate i) x'- A.Partial f' -> return $ C.StateProducing (NeedHeader f') $ front []- A.Fail _ contexts msg -> C.monadThrow $ ParseError contexts msg- push front (Isolate i) x = do- let (a, b) = S.splitAt i x- i' = i - S.length a- if i' == 0- then push- (front . (a:))- (NeedNewline $ A.parse newline)- b- else assert (S.null b) $ return $ C.StateProducing- (Isolate i')- (front [a])- push front (NeedNewline f) x =- case f x of- A.Done x' () -> do- let header = S8.pack "\r\n"- let addHeader = if sendHeaders then (header:) else id- push- (front . addHeader)- (NeedHeader $ A.parse parseChunkHeader)- x'- A.Partial f' -> return $ C.StateProducing (NeedNewline f') $ front []- A.Fail _ contexts msg -> C.monadThrow $ ParseError contexts msg- push front Complete leftover = do- let end = if sendHeaders then [S8.pack "0\r\n"] else []- lo = if S.null leftover then Nothing else Just leftover- return $ C.StateFinished lo $ front end- close _ = return []--chunkIt :: Monad m => C.Conduit Blaze.Builder m Blaze.Builder-chunkIt =- conduit- where- conduit = C.NeedInput push close- push xs = C.HaveOutput conduit (return ()) (chunkedTransferEncoding xs)- close = C.HaveOutput (return ()) (return ()) chunkedTransferTerminator
− Network/HTTP/Conduit/ConnInfo.hs
@@ -1,175 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE CPP #-}-module Network.HTTP.Conduit.ConnInfo- ( ConnInfo- , connClose- , connSink- , connSource- , sslClientConn- , socketConn- , TLSCertificateRejectReason(..)- , TLSCertificateUsage(..)- , getSocket-#if DEBUG- , printOpenSockets- , requireAllSocketsClosed- , clearSocketsList-#endif- ) where--import Control.Exception (SomeException, throwIO, try)-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)-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 qualified Data.Conduit as C--#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 :: C.MonadResource m => ConnInfo -> C.Sink ByteString m ()-connSink ConnInfo { connWrite = write } =- C.NeedInput push close- where- push bss = C.PipeM- (liftIO (write bss) >> return (C.NeedInput push close))- (return ())- close = return ()--connSource :: C.MonadResource m => ConnInfo -> C.Source m ByteString-connSource ConnInfo { connRead = read' } =- src- where- src = C.PipeM pull close- pull = do- bs <- liftIO read'- if S.null bs- then return (return ())- else return $ C.HaveOutput src close bs- close = return ()--#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 -> ([X509] -> IO TLSCertificateUsage) -> Handle -> IO ConnInfo-sslClientConn _desc onCerts h = do-#if DEBUG- i <- addSocket _desc-#endif- let tcp = defaultParams- { pConnectVersion = TLS10- , pAllowedVersions = [ TLS10, TLS11, TLS12 ]- , pCiphers = ciphersuite_all- , onCertificatesRecv = onCerts- }- gen <- makeSystem- istate <- client tcp gen h- handshake istate- return ConnInfo- { connRead = recvD istate- , connWrite = sendData istate . L.fromChunks . (:[])- , connClose = do-#if DEBUG- removeSocket i-#endif- bye istate- hClose h- }- where- recvD istate = do- x <- recvData istate- if S.null x- then recvD istate- else return x--getSocket :: String -> Int -> Maybe SocksConf -> IO NS.Socket-getSocket host' port' (Just socksConf) = do- socksConnectWith socksConf host' (PortNumber $ fromIntegral port')-getSocket host' port' Nothing = do- let hints = NS.defaultHints {- NS.addrFlags = [NS.AI_ADDRCONFIG]- , NS.addrSocketType = NS.Stream- }- (addr:_) <- NS.getAddrInfo (Just hints) (Just host') (Just $ show port')- sock <- NS.socket (NS.addrFamily addr) (NS.addrSocketType addr)- (NS.addrProtocol addr)- ee <- try' $ NS.connect sock (NS.addrAddress addr)- case ee of- Left e -> NS.sClose sock >> throwIO e- Right () -> return sock- where- try' :: IO a -> IO (Either SomeException a)- try' = try
− Network/HTTP/Conduit/Cookies.hs
@@ -1,266 +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 Network.HTTP.Types as W-import qualified Data.ByteString as BS-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 Data.Default--import qualified Network.HTTP.Conduit.Request as Req-import qualified Network.HTTP.Conduit.Response as Res--slash :: Integral a => a-slash = 47 -- '/'--isIpAddress :: W.Ascii -> 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 :: W.Ascii -> W.Ascii -> 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 -> W.Ascii-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 :: W.Ascii -> W.Ascii -> Bool-pathMatches requestPath cookiePath- | cookiePath == requestPath = True- | cookiePath `BS.isPrefixOf` requestPath && BS.singleton (BS.last cookiePath) == U.fromString "/" = True- | cookiePath `BS.isPrefixOf` requestPath && BS.singleton (BS.head remainder) == U.fromString "/" = True- | otherwise = False- where remainder = BS.drop (BS.length cookiePath) requestPath---- This corresponds to the description of a cookie detailed in Section 5.3 \"Storage Model\"-data Cookie = Cookie- { cookie_name :: W.Ascii- , cookie_value :: W.Ascii- , cookie_expiry_time :: UTCTime- , cookie_domain :: W.Ascii- , cookie_path :: W.Ascii- , 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 (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- | BS.length (cookie_path c1) > BS.length (cookie_path c2) = LT- | BS.length (cookie_path c1) < BS.length (cookie_path c2) = GT- | cookie_creation_time c1 > cookie_creation_time c2 = GT- | otherwise = LT--newtype CookieJar = CJ { expose :: [Cookie] }---- | empty cookie jar-instance Default CookieJar where- def = CJ []--instance Eq CookieJar where- (==) cj1 cj2 = (L.sort $ expose cj1) == (L.sort $ expose cj2)--instance Show CookieJar where- show = show . expose--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 :: W.Ascii -> Bool-isPublicSuffix _ = False---- | 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)- -> (W.Ascii, 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 && isPublicSuffix 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,5 +0,0 @@-module Network.HTTP.Conduit.Internal- ( module Network.HTTP.Conduit.Parser- ) where--import Network.HTTP.Conduit.Parser
− Network/HTTP/Conduit/Manager.hs
@@ -1,438 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-}-module Network.HTTP.Conduit.Manager- ( Manager- , ManagerSettings (..)- , ConnKey (..)- , newManager- , closeManager- , getConn- , ConnReuse (..)- , withManager- , ConnRelease- , ManagedConn (..)- , defaultCheckCerts- ) where--import Prelude hiding (catch)-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)-import Control.Monad.Trans.Resource- ( ResourceT, runResourceT, MonadResource (..)- , MonadThrow, MonadUnsafeIO- )-import Control.Concurrent (forkIO, threadDelay)-import Data.Time (UTCTime (..), Day (..), DiffTime, getCurrentTime, addUTCTime)-import Control.DeepSeq (deepseq)--import Network (connectTo, PortID (PortNumber), HostName)-import Network.Socket (socketToHandle)-import Data.Certificate.X509 (X509, encodeCertificate)--import qualified Network.HTTP.Types as W-import Network.TLS.Extra (certificateVerifyChain, certificateVerifyDomain)--import Network.HTTP.Conduit.ConnInfo-import Network.HTTP.Conduit.Util (hGetSome)-import Network.HTTP.Conduit.Parser (parserHeadersFromByteString)-import Network.HTTP.Conduit.Request-import Network.Socks5 (SocksConf, socksConnectWith)-import Data.Default-import Data.Maybe (mapMaybe)-import System.IO (Handle)---- | 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 :: W.Ascii -> [X509] -> IO TLSCertificateUsage- -- ^ Check if the server certificate is valid. Only relevant for HTTPS.- }--type X509Encoded = L.ByteString--instance Default ManagerSettings where- def = ManagerSettings- { managerConnCount = 10- , managerCheckCerts = defaultCheckCerts- }---- | Check certificates using the operating system's certificate checker.-defaultCheckCerts :: W.Ascii -> [X509] -> IO TLSCertificateUsage-defaultCheckCerts host' certs =- case certificateVerifyDomain (S8.unpack host') certs of- CertificateUsageAccept -> certificateVerifyChain certs- rejected -> return rejected---- | Keeps track of open connections for keep-alive. May be used--- concurrently by multiple threads.-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 :: W.Ascii -> [X509] -> IO TLSCertificateUsage- -- ^ Check if a certificate is valid.- , mCertCache :: !(I.IORef (Map.Map W.Ascii (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.- }--data NonEmptyList a =- One !a !UTCTime |- Cons !a !Int !UTCTime !(NonEmptyList a)---- | @ConnKey@ consists of a hostname, a port and a @Bool@--- specifying whether to use SSL.-data ConnKey = ConnKey !Text !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.-newManager :: ManagerSettings -> IO Manager-newManager ms = do- mapRef <- I.newIORef (Just Map.empty)- certCache <- I.newIORef Map.empty- _ <- forkIO $ reap mapRef certCache- return $ Manager mapRef (managerConnCount ms) (managerCheckCerts ms) certCache---- | Collect and destroy any stale connections.-reap :: I.IORef (Maybe (Map.Map ConnKey (NonEmptyList ConnInfo)))- -> I.IORef (Map.Map W.Ascii (Map.Map X509Encoded UTCTime))- -> IO ()-reap mapRef certCacheRef =- mask_ loop- where- loop = do- threadDelay (5 * 1000 * 1000)- 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--- 'newManager'.-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---- | Close all connections in a 'Manager'. Afterwards, the--- 'Manager' can be reused if desired.-closeManager :: Manager -> IO ()-closeManager manager = mask_ $ do- m <- I.atomicModifyIORef (mConns manager) $ \x -> (Nothing, x)- mapM_ (nonEmptyMapM_ safeConnClose) $ maybe [] Map.elems m--safeConnClose :: ConnInfo -> IO ()-safeConnClose ci = connClose ci `catch` \(_::SomeException) -> return ()--nonEmptyMapM_ :: Monad m => (a -> m ()) -> NonEmptyList a -> m ()-nonEmptyMapM_ f (One x _) = f x-nonEmptyMapM_ f (Cons x _ _ l) = f x >> nonEmptyMapM_ f l--getSocketConn- :: MonadResource m- => Manager- -> String- -> Int- -> Maybe SocksConf -- ^ optional socks proxy- -> m (ConnRelease m, ConnInfo, ManagedConn)-getSocketConn man host' port' socksProxy' =- getManagedConn man (ConnKey (T.pack host') port' False) $- getSocket 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 :: MonadResource m- => ([X509] -> IO TLSCertificateUsage)- -> Manager- -> String -- ^ host- -> Int -- ^ port- -> Maybe SocksConf -- ^ optional socks proxy- -> m (ConnRelease m, ConnInfo, ManagedConn)-getSslConn checkCert man host' port' socksProxy' =- getManagedConn man (ConnKey (T.pack host') port' True) $- (connectionTo host' (PortNumber $ fromIntegral port') socksProxy' >>= sslClientConn desc checkCert)- where- desc = socketDesc host' port' "secured"--getSslProxyConn- :: MonadResource m- => ([X509] -> IO TLSCertificateUsage)- -> S8.ByteString -- ^ Target host- -> Int -- ^ Target port- -> Manager- -> String -- ^ Proxy host- -> Int -- ^ Proxy port- -> Maybe SocksConf -- ^ optional SOCKS proxy- -> m (ConnRelease m, ConnInfo, ManagedConn)-getSslProxyConn checkCert thost tport man phost pport socksProxy' =- getManagedConn man (ConnKey (T.pack phost) pport True) $- doConnect >>= sslClientConn desc checkCert- where- desc = socketDesc phost pport "secured-proxy"- doConnect = do- h <- connectionTo phost (PortNumber $ fromIntegral pport) socksProxy'- L.hPutStr h $ Blaze.toLazyByteString connectRequest- hFlush h- r <- hGetSome h 2048- res <- parserHeadersFromByteString r- case res of- Right ((_, 200, _), _) -> return h- Right ((_, _, msg), _) -> hClose h >> proxyError (S8.unpack msg)- Left s -> hClose h >> proxyError 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 =- error $ "Proxy failed to CONNECT to '"- ++ S8.unpack thost ++ ":" ++ show tport ++ "' : " ++ s--data ManagedConn = Fresh | Reused---- | 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)--data ConnReuse = Reuse | DontReuse--type ConnRelease m = ConnReuse -> m ()--getConn :: MonadResource m- => Request m- -> Manager- -> m (ConnRelease m, ConnInfo, ManagedConn)-getConn req m =- go m connhost connport (socksProxy req)- where- h = host req- (useProxy, connhost, connport) =- case proxy req of- Just p -> (True, S8.unpack (proxyHost p), proxyPort p)- Nothing -> (False, S8.unpack h, port req)- go =- case (secure req, useProxy) of- (False, _) -> getSocketConn- (True, False) -> getSslConn $ checkCerts m h- (True, True) -> getSslProxyConn (checkCerts m h) h (port req)--checkCerts :: Manager -> W.Ascii -> [X509] -> IO TLSCertificateUsage-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 :: HostName -> PortID -> Maybe SocksConf -> IO Handle-connectionTo host' port' Nothing = connectTo host' port'-connectionTo host' port' (Just socksConf) =- socksConnectWith socksConf host' port' >>= flip socketToHandle ReadWriteMode
− Network/HTTP/Conduit/Parser.hs
@@ -1,122 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleContexts #-}-module Network.HTTP.Conduit.Parser- ( sinkHeaders- , newline- , parserHeadersFromByteString- , parseChunkHeader- ) where--import Prelude hiding (take, takeWhile)-import Control.Applicative-import Data.Word (Word8)--import qualified Data.ByteString as S-import qualified Data.ByteString.Char8 as S8--import Data.Attoparsec--import Data.Conduit.Attoparsec (sinkParser)-import Data.Conduit (Sink, MonadResource, MonadThrow)-import Control.Monad (when)---type Header = (S.ByteString, S.ByteString)--parseHeader :: Parser Header-parseHeader = do- k <- takeWhile1 notNewlineColon- _ <- word8 58 -- colon- skipWhile isSpace- v <- takeWhile notNewline- newline- return (k, v)--notNewlineColon, isSpace, notNewline :: Word8 -> Bool--notNewlineColon 10 = False -- LF-notNewlineColon 13 = False -- CR-notNewlineColon 58 = False -- colon-notNewlineColon _ = True--isSpace 32 = True-isSpace _ = False--notNewline 10 = False-notNewline 13 = False-notNewline _ = True--newline :: Parser ()-newline =- lf <|> (cr >> lf)- where- word8' x = word8 x >> return ()- lf = word8' 10- cr = word8' 13--parseHeaders :: Parser (Status, [Header])-parseHeaders = do- s <- parseStatus <?> "HTTP status line"- h <- manyTill parseHeader newline <?> "Response headers"- return (s, h)--sinkHeaders :: (MonadThrow m, MonadResource m) => Sink S.ByteString m (Status, [Header])-sinkHeaders = sinkParser parseHeaders---parserHeadersFromByteString :: Monad m => S.ByteString -> m (Either String (Status, [Header]))-parserHeadersFromByteString s = return $ parseOnly parseHeaders s---type Status = (S.ByteString, Int, S.ByteString)--parseStatus :: Parser Status-parseStatus = do- end <- atEnd- when end $ fail "EOF reached"- _ <- manyTill (take 1 >> return ()) (try $ string "HTTP/") <?> "HTTP/"- ver <- takeWhile1 $ not . isSpace- _ <- word8 32 -- space- statCode <- takeWhile1 $ not . isSpace- statCode' <-- case reads $ S8.unpack statCode of- [] -> fail $ "Invalid status code: " ++ S8.unpack statCode- (x, _):_ -> return x- _ <- word8 32- statMsg <- takeWhile1 $ notNewline- newline- if (statCode == "100")- then newline >> parseStatus- else return (ver, statCode', statMsg)--parseChunkHeader :: Parser Int-parseChunkHeader = do- len <- hexs- skipWhile isSpace- newline <|> attribs- return len--attribs :: Parser ()-attribs = do- _ <- word8 59 -- colon- skipWhile notNewline- newline--hexs :: Parser Int-hexs = do- ws <- many1 hex- return $ foldl1 (\a b -> a * 16 + b) $ map fromIntegral ws--hex :: Parser Word8-hex =- (digit <|> upper <|> lower) <?> "Hexadecimal digit"- where- digit = do- d <- satisfy $ \w -> (w >= 48 && w <= 57)- return $ d - 48- upper = do- d <- satisfy $ \w -> (w >= 65 && w <= 70)- return $ d - 55- lower = do- d <- satisfy $ \w -> (w >= 97 && w <= 102)- return $ d - 87
− Network/HTTP/Conduit/Request.hs
@@ -1,349 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}-module Network.HTTP.Conduit.Request- ( Request (..)- , RequestBody (..)- , ContentType- , Proxy (..)- , parseUrl- , setUriRelative- , browserDecompress- , HttpException (..)- , alwaysDecompress- , addProxy- , applyBasicAuth- , urlEncodedBody- , needsGunzip- , requestBuilder- ) where--import Data.Int (Int64)-import Data.Maybe (fromMaybe)-import Data.Monoid (mempty, mappend)-import Data.Typeable (Typeable)--import Data.Default (Default (def))--import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString)-import Blaze.ByteString.Builder.Char8 (fromChar)-import qualified Blaze.ByteString.Builder as Blaze--import qualified Data.Conduit as C-import qualified Data.Conduit.List as CL--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.Socks5 (SocksConf)-import Network.URI (URI (..), URIAuth (..), parseURI, relativeTo, escapeURIString, isAllowedInURI)--import Control.Exception (Exception, SomeException, toException)-import Control.Failure (Failure (failure))-import Codec.Binary.UTF8.String (encodeString)-import qualified Data.CaseInsensitive as CI-import qualified Data.ByteString.Base64 as B64--import Network.HTTP.Conduit.Chunk (chunkIt)-import Network.HTTP.Conduit.Util (readDec, (<>))--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).- , host :: W.Ascii- , port :: Int- , path :: W.Ascii- -- ^ Everything from the host to the query string.- , queryString :: W.Ascii- , requestHeaders :: W.RequestHeaders- , requestBody :: RequestBody m- , proxy :: Maybe Proxy- -- ^ Optional HTTP proxy.- , socksProxy :: Maybe SocksConf- -- ^ Optional SOCKS proxy.- , 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 -> Maybe SomeException- -- ^ Check the status code. Note that this will run after all redirects are- -- performed. Default: return a @StatusCodeException@ on non-2XX responses.- }---- | 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 Blaze.Builder- | RequestBodySource Int64 (C.Source m Blaze.Builder)- | RequestBodySourceChunked (C.Source m Blaze.Builder)---- | Define a HTTP proxy, consisting of a hostname and port number.--data Proxy = Proxy- { proxyHost :: W.Ascii -- ^ The host name of the HTTP proxy.- , proxyPort :: Int -- ^ The port number of the HTTP proxy.- }---- | 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 . encodeString---- | 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 =- case uri `relativeTo` getUri req of- Just uri' -> setUri req uri'- Nothing -> failure $ InvalidUrlException (show uri) "Invalid URL"---- | 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 . 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 Default (Request m) where- def = Request- { host = "localhost"- , port = 80- , secure = False- , requestHeaders = []- , path = "/"- , queryString = S8.empty- , requestBody = RequestBodyLBS L.empty- , method = "GET"- , proxy = Nothing- , socksProxy = Nothing- , rawBody = False- , decompress = browserDecompress- , redirectCount = 10- , checkStatus = \s@(W.Status sci _) hs ->- if 200 <= sci && sci < 300- then Nothing- else Just $ toException $ StatusCodeException s hs- }--data HttpException = StatusCodeException W.Status W.ResponseHeaders- | InvalidUrlException String String- | TooManyRedirects- | UnparseableRedirect- | TooManyRetries- | HttpParserException String- | HandshakeFailed- | OverlongHeaders- deriving (Show, Typeable)-instance Exception HttpException---- | 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 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 paramters 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 =- CL.sourceList [builder] `mappend` bodySource- where- sourceSingle = CL.sourceList . return-- (contentLength, bodySource) =- case requestBody req of- RequestBodyLBS lbs -> (Just $ L.length lbs, sourceSingle $ fromLazyByteString lbs)- RequestBodyBS bs -> (Just $ fromIntegral $ S.length bs, sourceSingle $ fromByteString bs)- RequestBodyBuilder i b -> (Just $ i, sourceSingle b)- RequestBodySource i source -> (Just i, source)- RequestBodySourceChunked source -> (Nothing, 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))-- 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")-- headerPairs :: W.RequestHeaders- headerPairs- = ("Host", hh)- : ("Accept-Encoding", "gzip")- : (contentLengthHeader contentLength)- (requestHeaders req)-- builder :: Builder- builder =- fromByteString (method req)- <> fromByteString " "- <> (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,154 +0,0 @@-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}-module Network.HTTP.Conduit.Response- ( Response (..)- , getRedirectedRequest- , getResponse- , lbsResponse- ) where--import Control.Arrow (first)-import Data.Typeable (Typeable)-import Data.Monoid (mempty)-import Control.Monad (liftM)--import Control.Exception (throwIO)-import Control.Monad.IO.Class (liftIO)--import qualified Data.ByteString.Char8 as S8-import qualified Data.ByteString.Lazy as L--import qualified Data.CaseInsensitive as CI--import Control.Monad.Trans.Resource (MonadResource)-import Control.Monad.Trans.Class (lift)-import qualified Data.Conduit as C-import qualified Data.Conduit.Zlib as CZ-import qualified Data.Conduit.Binary as CB-import qualified Data.Conduit.List as CL-import qualified Data.Conduit.Internal--import qualified Network.HTTP.Types as W-import Network.URI (parseURIReference)--import Network.HTTP.Conduit.Manager-import Network.HTTP.Conduit.Request-import Network.HTTP.Conduit.Util-import Network.HTTP.Conduit.Parser-import Network.HTTP.Conduit.Chunk--import Data.Void (absurd)---- | A simple representation of the HTTP response created by 'lbsConsumer'.-data Response body = Response- { responseStatus :: W.Status- , responseVersion :: W.HttpVersion- , responseHeaders :: W.ResponseHeaders- , responseBody :: body- }- deriving (Show, Eq, Typeable)---- | Since 1.1.2.-instance Functor Response where- fmap f (Response status v headers body) = Response status v headers (f body)---- | 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 = E.catch (C.runResourceT $ http req' man >> return [req'])--- > (\ (StatusCodeException status headers) -> do--- > l <- myHttp (fromJust $ nextRequest status headers) man--- > return $ req' : l)--- > where req' = req { redirectCount = 0 }--- > nextRequest status headers = getRedirectedRequest req' headers $ W.statusCode status-getRedirectedRequest :: Request m -> W.ResponseHeaders -> Int -> Maybe (Request m)-getRedirectedRequest req hs 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 ""- }- else req'- | otherwise = Nothing---- | Convert a 'Response' that has a 'C.Source' body to one with a lazy--- 'L.ByteString' body.-lbsResponse :: Monad m- => m (Response (C.Source m S8.ByteString))- -> m (Response L.ByteString)-lbsResponse mres = do- res <- mres- bss <- responseBody res C.$$ CL.consume- return res- { responseBody = L.fromChunks bss- }--checkHeaderLength :: MonadResource m- => Int- -> C.Sink S8.ByteString m a- -> C.Sink S8.ByteString m a-checkHeaderLength len C.NeedInput{}- | len <= 0 =- let x = liftIO $ throwIO OverlongHeaders- in C.PipeM x (lift x)-checkHeaderLength len (C.NeedInput pushI closeI) = C.NeedInput- (\bs -> checkHeaderLength- (len - S8.length bs)- (pushI bs)) closeI-checkHeaderLength len (C.PipeM msink close) = C.PipeM (liftM (checkHeaderLength len) msink) close-checkHeaderLength _ s@C.Done{} = s-checkHeaderLength _ (C.HaveOutput _ _ o) = absurd o--getResponse :: MonadResource m- => ConnRelease m- -> Request m- -> C.Source m S8.ByteString- -> m (Response (C.Source m S8.ByteString))-getResponse connRelease req@(Request {..}) src1 = do- (src2, ((vbs, sc, sm), hs)) <- src1 C.$$+ checkHeaderLength 4096 sinkHeaders- 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'- 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- return mempty- else do- let src3 =- if ("transfer-encoding", "chunked") `elem` hs'- then src2 C.$= chunkedConduit rawBody- else- case mcl of- Just len -> src2 C.$= CB.isolate len- Nothing -> src2- let src4 =- if needsGunzip req hs'- then src3 C.$= CZ.ungzip- else src3- return $ Data.Conduit.Internal.addCleanup cleanup src4-- return $ Response s version hs' body
− Network/HTTP/Conduit/Util.hs
@@ -1,71 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleContexts #-}-module Network.HTTP.Conduit.Util- ( hGetSome- , (<>)- , readDec- , hasNoBody- ) where--import Data.Monoid (Monoid, mappend)--import qualified Data.ByteString.Char8 as S8--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
+ 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,122 +1,98 @@+cabal-version: >= 1.10 name: http-conduit-version: 1.4.1.10+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 attoparsec for parsing the actual contents of the HTTP connection. It also provides higher-level functions which allow you to avoid direct usage of conduits. See <http://www.yesodweb.com/book/http-conduit> for more information.+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+ , certificate.pem+ , key.pem+ , README.md+ , ChangeLog.md -flag network-bytestring- default: False+flag aeson+ manual: True+ description: Enable the dependency on aeson+ default: True library- build-depends: base >= 4 && < 5- , bytestring >= 0.9.1.4 && < 0.10- , transformers >= 0.2 && < 0.4- , failure >= 0.1- , resourcet >= 0.3 && < 0.4- , conduit >= 0.4.1 && < 0.5- , zlib-conduit >= 0.4 && < 0.5- , blaze-builder-conduit >= 0.4 && < 0.5- , attoparsec-conduit >= 0.4 && < 0.5- , attoparsec >= 0.8.0.2 && < 0.11- , utf8-string >= 0.3.4 && < 0.4- , blaze-builder >= 0.2.1 && < 0.4- , http-types >= 0.6 && < 0.7- , cprng-aes >= 0.2 && < 0.3- , tls >= 0.9.3 && < 0.10- , tls-extra >= 0.4.5 && < 0.5- , monad-control >= 0.3 && < 0.4- , containers >= 0.2- , certificate >= 1.2 && < 1.3- , case-insensitive >= 0.2- , base64-bytestring >= 0.1 && < 0.2- , asn1-data >= 0.5.1 && < 0.7- , data-default >= 0.3 && < 0.5- , text- , transformers-base >= 0.4 && < 0.5- , lifted-base >= 0.1 && < 0.2- , socks >= 0.4 && < 0.5- , time- , cookie >= 0.4 && < 0.5- , void >= 0.5.5 && < 0.6- , regex-compat+ default-language: Haskell2010+ build-depends: base >= 4.10 && < 5+ , attoparsec+ , bytestring >= 0.9.1.4+ , transformers >= 0.2+ , resourcet >= 1.1+ , conduit >= 1.2+ , conduit-extra >= 1.1+ , http-types >= 0.7+ , http-client >= 0.5.13 && < 0.8+ , http-client-tls >= 0.3 && < 0.4 , mtl- , deepseq- 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 && < 2.4+ , 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.Browser- Network.HTTP.Conduit.Internal- 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.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+ , 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- , attoparsec-conduit- , attoparsec+ , 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- , warp >= 1.2.1- , socks+ , unliftio+ , wai >= 3.0 && < 3.3+ , warp >= 3.0.0.2 && < 3.4+ , wai-conduit , http-types , cookie- , regex-compat- , network-conduit+ , http-client+ , http-conduit+ , conduit-extra+ , streaming-commons+ , temporary , resourcet- , void- , deepseq- , mtl+ , 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-----
+ multipart-example.bin view
binary file changed (absent → 4267 bytes)
+ nyan.gif view
binary file changed (absent → 3422 bytes)
+ test/CookieTest.hs view
@@ -0,0 +1,580 @@+{-# 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.Client+import qualified Network.HTTP.Conduit as HC+import Data.ByteString.UTF8+import Data.Monoid+import Data.Time.Clock+import Data.Time.Calendar+import qualified Data.CaseInsensitive as CI+import Web.Cookie++-- 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"+ , cookie_expiry_time = default_time+ , cookie_domain = fromString "www.google.com"+ , cookie_path = fromString "/"+ , cookie_creation_time = default_time+ , cookie_last_access_time = default_time+ , cookie_persistent = False+ , cookie_host_only = False+ , cookie_secure_only = False+ , cookie_http_only = False+ }++default_time :: UTCTime+default_time = UTCTime (ModifiedJulianDay 56200) (secondsToDiffTime 0)++default_diff_time :: DiffTime+default_diff_time = secondsToDiffTime 1209600++default_set_cookie :: SetCookie+default_set_cookie = def { setCookieName = fromString "name"+ , setCookieValue = fromString "value"+ , setCookiePath = Just $ fromString "/"+ , setCookieExpires = Just default_time+ , setCookieMaxAge = Just default_diff_time+ , setCookieDomain = Just $ fromString "www.google.com"+ , setCookieHttpOnly = False+ , setCookieSecure = False+ }++testValidIp :: IO ()+testValidIp = assertBool "Couldn't parse valid IP address" $+ isIpAddress $ fromString "1.2.3.4"++testIpNumTooHigh :: IO ()+testIpNumTooHigh = assertBool "One of the digits in the IP address is too large" $+ not $ isIpAddress $ fromString "501.2.3.4"++testTooManySegmentsInIp :: IO ()+testTooManySegmentsInIp = assertBool "Too many segments in the ip address" $+ not $ isIpAddress $ fromString "1.2.3.4.5"++testCharsInIp :: IO ()+testCharsInIp = assertBool "Chars are not allowed in IP addresses" $+ not $ isIpAddress $ fromString "1.2a3.4.5"++testDomainMatchesSuccess :: IO ()+testDomainMatchesSuccess = assertBool "Domains should match" $+ domainMatches (fromString "www.google.com") (fromString "google.com")++testSameDomain :: IO ()+testSameDomain = assertBool "Same domain should match" $+ domainMatches domain domain+ where domain = fromString "www.google.com"++testSiblingDomain :: IO ()+testSiblingDomain = assertBool "Sibling domain should not match" $+ not $ domainMatches (fromString "www.google.com") (fromString "secure.google.com")++testParentDomain :: IO ()+testParentDomain = assertBool "Parent domain should fail" $+ not $ domainMatches (fromString "google.com") (fromString "www.google.com")++testNaiveSuffixDomain :: IO ()+testNaiveSuffixDomain = assertBool "Naively checking for suffix for domain matching should fail" $+ not $ domainMatches (fromString "agoogle.com") (fromString "google.com")++testDefaultPath :: IO ()+testDefaultPath = assertEqual "Getting default path from a request"+ (fromString "/") (defaultPath default_request)++testShortDefaultPath :: IO ()+testShortDefaultPath = assertEqual "Getting default path from a short path"+ (fromString "/") (defaultPath $ default_request {HC.path = fromString "/search"})++testPopulatedDefaultPath :: IO ()+testPopulatedDefaultPath = assertEqual "Getting default path from a request with a path"+ (fromString "/search") (defaultPath $ default_request {HC.path = fromString "/search/term"})++testParamsDefaultPath :: IO ()+testParamsDefaultPath = assertEqual "Getting default path from a request with a path and GET params"+ (fromString "/search") (defaultPath $ default_request {HC.path = fromString "/search/term?var=val"})++testDefaultPathEndingInSlash :: IO ()+testDefaultPathEndingInSlash = assertEqual "Getting default path that ends in a slash"+ (fromString "/search/term") (defaultPath $ default_request {HC.path = fromString "/search/term/"})++testSamePathsMatch :: IO ()+testSamePathsMatch = assertBool "The same path should match" $+ pathMatches path' path'+ where path' = fromString "/a/path"++testPathSlashAtEnd :: IO ()+testPathSlashAtEnd = assertBool "Putting the slash at the end should still match paths" $+ pathMatches (fromString "/a/path/to/here") (fromString "/a/path/")++testPathNoSlashAtEnd :: IO ()+testPathNoSlashAtEnd = assertBool "Not putting the slash at the end should still match paths" $+ pathMatches (fromString "/a/path/to/here") (fromString "/a/path")++testDivergingPaths :: IO ()+testDivergingPaths = assertBool "Diverging paths don't match" $+ not $ pathMatches (fromString "/a/path/to/here") (fromString "/a/different/path")++testCookieEqualitySuccess :: IO ()+testCookieEqualitySuccess = assertEqual "The same cookies should be equal"+ cookie cookie+ where cookie = default_cookie++testCookieEqualityResiliance :: IO ()+testCookieEqualityResiliance = assertBool "Cookies should still be equal if extra options are changed" $+ (default_cookie {cookie_persistent = True}) `equivCookie` (default_cookie {cookie_host_only = True})++testDomainChangesEquality :: IO ()+testDomainChangesEquality = assertBool "Changing the domain should make cookies not equal" $+ default_cookie /= (default_cookie {cookie_domain = fromString "/search"})++testRemoveCookie :: IO ()+testRemoveCookie = assertEqual "Removing a cookie works"+ (Just default_cookie, createCookieJar []) (removeExistingCookieFromCookieJar default_cookie $ createCookieJar [default_cookie])++testRemoveNonexistantCookie :: IO ()+testRemoveNonexistantCookie = assertEqual "Removing a nonexistent cookie doesn't work"+ (Nothing, createCookieJar [default_cookie]) (removeExistingCookieFromCookieJar (default_cookie {cookie_name = fromString "key2"}) $ createCookieJar [default_cookie])++testRemoveCorrectCookie :: IO ()+testRemoveCorrectCookie = assertEqual "Removing only the correct cookie"+ (Just search_for, createCookieJar [red_herring]) (removeExistingCookieFromCookieJar search_for $ createCookieJar [red_herring, search_for])+ where search_for = default_cookie {cookie_name = fromString "name1"}+ red_herring = default_cookie {cookie_name = fromString "name2"}++testEvictExpiredCookies :: IO ()+testEvictExpiredCookies = assertEqual "Evicting expired cookies works"+ (createCookieJar [a, c]) (evictExpiredCookies (createCookieJar [a, b, c, d]) middle)+ where a = default_cookie { cookie_name = fromString "a"+ , cookie_expiry_time = UTCTime (ModifiedJulianDay 3) (secondsToDiffTime 0)+ }+ b = default_cookie { cookie_name = fromString "b"+ , cookie_expiry_time = UTCTime (ModifiedJulianDay 1) (secondsToDiffTime 0)+ }+ c = default_cookie { cookie_name = fromString "c"+ , cookie_expiry_time = UTCTime (ModifiedJulianDay 3) (secondsToDiffTime 0)+ }+ d = default_cookie { cookie_name = fromString "d"+ , cookie_expiry_time = UTCTime (ModifiedJulianDay 1) (secondsToDiffTime 0)+ }+ middle = UTCTime (ModifiedJulianDay 2) (secondsToDiffTime 0)++testEvictNoCookies :: IO ()+testEvictNoCookies = assertEqual "Evicting empty cookie jar"+ (createCookieJar []) (evictExpiredCookies (createCookieJar []) middle)+ where middle = UTCTime (ModifiedJulianDay 2) (secondsToDiffTime 0)++testComputeCookieStringUpdateLastAccessTime :: IO ()+testComputeCookieStringUpdateLastAccessTime = assertEqual "Updates last access time upon using cookies"+ (fromString "name=value", out_cookie_jar) (computeCookieString request cookie_jar now True)+ where request = default_request+ cookie_jar = createCookieJar [default_cookie]+ now = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 1)+ out_cookie_jar = createCookieJar [default_cookie {cookie_last_access_time = now}]++testComputeCookieStringHostOnly :: IO ()+testComputeCookieStringHostOnly = assertEqual "Host only cookies should match host exactly"+ (fromString "name=value", cookie_jar) (computeCookieString request cookie_jar default_time True)+ where request = default_request+ cookie_jar = createCookieJar [default_cookie {cookie_host_only = True}]++testComputeCookieStringHostOnlyFilter :: IO ()+testComputeCookieStringHostOnlyFilter = assertEqual "Host only cookies shouldn't match subdomain"+ (fromString "", cookie_jar) (computeCookieString request cookie_jar default_time True)+ where request = default_request {HC.host = fromString "sub1.sub2.google.com"}+ cookie_jar = createCookieJar [default_cookie { cookie_host_only = True+ , cookie_domain = fromString "sub2.google.com"+ }+ ]++testComputeCookieStringDomainMatching :: IO ()+testComputeCookieStringDomainMatching = assertEqual "Domain matching works for new requests"+ (fromString "name=value", cookie_jar) (computeCookieString request cookie_jar default_time True)+ where request = default_request {HC.host = fromString "sub1.sub2.google.com"}+ cookie_jar = createCookieJar [default_cookie {cookie_domain = fromString "sub2.google.com"}]++testComputeCookieStringPathMatching :: IO ()+testComputeCookieStringPathMatching = assertEqual "Path matching works for new requests"+ (fromString "name=value", cookie_jar) (computeCookieString request cookie_jar default_time True)+ where request = default_request {HC.path = fromString "/a/path/to/nowhere"}+ cookie_jar = createCookieJar [default_cookie {cookie_path = fromString "/a/path"}]++testComputeCookieStringPathMatchingFails :: IO ()+testComputeCookieStringPathMatchingFails = assertEqual "Path matching fails when it should"+ (fromString "", cookie_jar) (computeCookieString request cookie_jar default_time True)+ where request = default_request {HC.path = fromString "/a/different/path/to/nowhere"}+ cookie_jar = createCookieJar [default_cookie {cookie_path = fromString "/a/path"}]++testComputeCookieStringPathMatchingWithParms :: IO ()+testComputeCookieStringPathMatchingWithParms = assertEqual "Path matching succeeds when request has GET params"+ (fromString "name=value", cookie_jar) (computeCookieString request cookie_jar default_time True)+ where request = default_request {HC.path = fromString "/a/path/to/nowhere?var=val"}+ cookie_jar = createCookieJar [default_cookie {cookie_path = fromString "/a/path"}]++testComputeCookieStringSecure :: IO ()+testComputeCookieStringSecure = assertEqual "Secure flag filters properly"+ (fromString "", cookie_jar) (computeCookieString default_request cookie_jar default_time True)+ where cookie_jar = createCookieJar [default_cookie {cookie_secure_only = True}]++testComputeCookieStringHttpOnly :: IO ()+testComputeCookieStringHttpOnly = assertEqual "http-only flag filters properly"+ (fromString "", cookie_jar) (computeCookieString default_request cookie_jar default_time False)+ where cookie_jar = createCookieJar [default_cookie {cookie_http_only = True}]++testComputeCookieStringSort :: IO ()+testComputeCookieStringSort = 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"+ , cookie_path = fromString "/all/encompassing/request"+ }+ , default_cookie { cookie_name = fromString "c2"+ , cookie_value = fromString "v2"+ , cookie_path = fromString "/all"+ }+ , default_cookie { cookie_name = fromString "c3"+ , cookie_value = fromString "v3"+ , cookie_path = fromString "/all/encompassing"+ , cookie_creation_time = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 1)+ }+ , default_cookie { cookie_name = fromString "c4"+ , cookie_value = fromString "v4"+ , cookie_path = fromString "/all/encompassing"+ , cookie_creation_time = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 2)+ }+ ]+ cookie_jar_out = createCookieJar [ default_cookie { cookie_name = fromString "c1"+ , cookie_value = fromString "v1"+ , cookie_path = fromString "/all/encompassing/request"+ , cookie_last_access_time = now+ }+ , default_cookie { cookie_name = fromString "c2"+ , cookie_value = fromString "v2"+ , cookie_path = fromString "/all"+ , cookie_last_access_time = now+ }+ , default_cookie { cookie_name = fromString "c3"+ , cookie_value = fromString "v3"+ , cookie_path = fromString "/all/encompassing"+ , cookie_creation_time = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 1)+ , cookie_last_access_time = now+ }+ , default_cookie { cookie_name = fromString "c4"+ , cookie_value = fromString "v4"+ , cookie_path = fromString "/all/encompassing"+ , cookie_creation_time = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 2)+ , cookie_last_access_time = now+ }+ ]+ request = default_request {HC.path = fromString "/all/encompassing/request/path"}+ format_output = computeCookieString request cookie_jar default_time False++testInsertCookiesIntoRequestWorks :: IO ()+testInsertCookiesIntoRequestWorks = assertEqual "Inserting cookies works"+ [(CI.mk $ fromString "Cookie", fromString "key=val")] out_headers+ where out_headers = HC.requestHeaders req+ (req, _) = insertCookiesIntoRequest req' cookie_jar default_time+ cookie_jar = createCookieJar [ default_cookie { cookie_name = fromString "key"+ , cookie_value = fromString "val"+ }+ ]+ req' = default_request {HC.requestHeaders = [(CI.mk $ fromString "Cookie",+ fromString "otherkey=otherval")]}++testReceiveSetCookie :: IO ()+testReceiveSetCookie = assertBool "Receiving a Set-Cookie" $+ (createCookieJar [default_cookie]) `equivCookieJar` (receiveSetCookie default_set_cookie default_request default_time True $ createCookieJar [])++testReceiveSetCookieTrailingDot :: IO ()+testReceiveSetCookieTrailingDot = assertEqual "Receiving a Set-Cookie with a trailing domain dot"+ (createCookieJar []) (receiveSetCookie set_cookie default_request default_time True $ createCookieJar [])+ where set_cookie = default_set_cookie {setCookieDomain = Just $ fromString "www.google.com."}++testReceiveSetCookieLeadingDot :: IO ()+testReceiveSetCookieLeadingDot = 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 :: 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 :: 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 :: IO ()+testReceiveSetCookieNonMatchingDomain = assertEqual "Receiving cookie with non-matching domain"+ (createCookieJar []) (receiveSetCookie set_cookie default_request default_time True $ createCookieJar [])+ where set_cookie = default_set_cookie {setCookieDomain = Just $ fromString "www.wikipedia.org"}++testReceiveSetCookieHostOnly :: IO ()+testReceiveSetCookieHostOnly = assertBool "Checking host-only flag gets set" $+ cookie_host_only $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar []+ where set_cookie = default_set_cookie {setCookieDomain = Nothing}++testReceiveSetCookieHostOnlyNotSet :: IO ()+testReceiveSetCookieHostOnlyNotSet = assertBool "Checking host-only flag doesn't get set" $+ not $ cookie_host_only $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar []+ where set_cookie = default_set_cookie {setCookieDomain = Just $ fromString "google.com"}++testReceiveSetCookieHttpOnly :: IO ()+testReceiveSetCookieHttpOnly = assertBool "Checking http-only flag gets set" $+ cookie_http_only $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar []+ where set_cookie = default_set_cookie {setCookieHttpOnly = True}++testReceiveSetCookieHttpOnlyNotSet :: IO ()+testReceiveSetCookieHttpOnlyNotSet = assertBool "Checking http-only flag doesn't get set" $+ not $ cookie_http_only $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar []+ where set_cookie = default_set_cookie {setCookieHttpOnly = False}++testReceiveSetCookieHttpOnlyDrop :: IO ()+testReceiveSetCookieHttpOnlyDrop = assertEqual "Checking non http request gets dropped"+ (createCookieJar []) (receiveSetCookie set_cookie default_request default_time False $ createCookieJar [])+ where set_cookie = default_set_cookie {setCookieHttpOnly = True}++testReceiveSetCookieName :: IO ()+testReceiveSetCookieName = assertEqual "Name gets set correctly"+ (fromString "name") (cookie_name $ head $ destroyCookieJar $ receiveSetCookie default_set_cookie default_request default_time True $ createCookieJar [])++testReceiveSetCookieValue :: IO ()+testReceiveSetCookieValue = assertEqual "Value gets set correctly"+ (fromString "value") (cookie_value $ head $ destroyCookieJar $ receiveSetCookie default_set_cookie default_request default_time True $ createCookieJar [])++testReceiveSetCookieExpiry :: IO ()+testReceiveSetCookieExpiry = assertEqual "Expiry gets set correctly"+ now_plus_diff_time (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie default_set_cookie default_request default_time True $ createCookieJar [])+ where now_plus_diff_time = ((fromRational $ toRational default_diff_time) `addUTCTime` default_time)++testReceiveSetCookieNoMaxAge :: IO ()+testReceiveSetCookieNoMaxAge = assertEqual "Expiry is based on the given value"+ default_time (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie cookie_without_max_age default_request default_time True $ createCookieJar [])+ where cookie_without_max_age = default_set_cookie {setCookieMaxAge = Nothing}++testReceiveSetCookieNoExpiry :: IO ()+testReceiveSetCookieNoExpiry = assertEqual "Expiry is based on max age"+ now_plus_diff_time (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie cookie_without_expiry default_request default_time True $ createCookieJar [])+ where now_plus_diff_time = ((fromRational $ toRational default_diff_time) `addUTCTime` default_time)+ cookie_without_expiry = default_set_cookie {setCookieExpires = Nothing}++testReceiveSetCookieNoExpiryNoMaxAge :: IO ()+testReceiveSetCookieNoExpiryNoMaxAge = assertBool "Expiry is set to a future date" $+ default_time < (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie basic_cookie default_request default_time True $ createCookieJar [])+ where basic_cookie = default_set_cookie { setCookieExpires = Nothing, setCookieMaxAge = Nothing }++testReceiveSetCookiePath :: IO ()+testReceiveSetCookiePath = assertEqual "Path gets set correctly"+ (fromString "/a/path") (cookie_path $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar [])+ where set_cookie = default_set_cookie {setCookiePath = Just $ fromString "/a/path"}++testReceiveSetCookieNoPath :: IO ()+testReceiveSetCookieNoPath = assertEqual "Path gets set correctly when nonexistent"+ (fromString "/a/path/to") (cookie_path $ head $ destroyCookieJar $ receiveSetCookie set_cookie request default_time True $ createCookieJar [])+ where set_cookie = default_set_cookie {setCookiePath = Nothing}+ request = default_request {HC.path = fromString "/a/path/to/nowhere"}++testReceiveSetCookieCreationTime :: IO ()+testReceiveSetCookieCreationTime = assertEqual "Creation time gets set correctly"+ now (cookie_creation_time $ head $ destroyCookieJar $ receiveSetCookie default_set_cookie default_request now True $ createCookieJar [])+ where now = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 1)++testReceiveSetCookieAccessTime :: IO ()+testReceiveSetCookieAccessTime = assertEqual "Last access time gets set correctly"+ now (cookie_last_access_time $ head $ destroyCookieJar $ receiveSetCookie default_set_cookie default_request now True $ createCookieJar [])+ where now = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 1)++testReceiveSetCookiePersistent :: IO ()+testReceiveSetCookiePersistent = assertBool "Persistent flag gets set correctly" $+ cookie_persistent $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar []+ where set_cookie = default_set_cookie {setCookieExpires = Just default_time}++testReceiveSetCookieSecure :: IO ()+testReceiveSetCookieSecure = assertBool "Secure flag gets set correctly" $+ cookie_secure_only $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar []+ where set_cookie = default_set_cookie {setCookieSecure = True}++testReceiveSetCookieMaxAge :: IO ()+testReceiveSetCookieMaxAge = assertEqual "Max-Age gets set correctly"+ total (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request now True $ createCookieJar [])+ where set_cookie = default_set_cookie { setCookieExpires = Nothing+ , setCookieMaxAge = Just $ secondsToDiffTime 10+ }+ now = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 12)+ total = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 22)++testReceiveSetCookiePreferMaxAge :: IO ()+testReceiveSetCookiePreferMaxAge = assertEqual "Max-Age is preferred over Expires"+ total (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request now True $ createCookieJar [])+ where set_cookie = default_set_cookie { setCookieExpires = Just exp+ , setCookieMaxAge = Just $ secondsToDiffTime 10+ }+ exp = UTCTime (ModifiedJulianDay 11) (secondsToDiffTime 5)+ now = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 12)+ total = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 22)++testReceiveSetCookieExisting :: IO ()+testReceiveSetCookieExisting = assertEqual "Existing cookie gets updated"+ t (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie set_cookie default_request default_time True $ createCookieJar [default_cookie])+ where set_cookie = default_set_cookie { setCookieExpires = Just t+ , setCookieMaxAge = Nothing+ }+ t = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 12)++testReceiveSetCookieExistingCreation :: IO ()+testReceiveSetCookieExistingCreation = assertEqual "Creation time gets updated in existing cookie"+ default_time (cookie_creation_time $ head $ destroyCookieJar $ receiveSetCookie default_set_cookie default_request now True $ createCookieJar [default_cookie])+ where now = UTCTime (ModifiedJulianDay 10) (secondsToDiffTime 12)++testReceiveSetCookieExistingHttpOnly :: IO ()+testReceiveSetCookieExistingHttpOnly = assertEqual "Existing http-only cookie gets dropped"+ default_time (cookie_expiry_time $ head $ destroyCookieJar $ receiveSetCookie default_set_cookie default_request default_time False $ createCookieJar [existing_cookie])+ where existing_cookie = default_cookie {cookie_http_only = True}++testMonoidPreferRecent :: IO ()+testMonoidPreferRecent = assertEqual "Monoid prefers more recent cookies"+ (cct $ createCookieJar [c2]) (cct $ createCookieJar [c1] `Data.Monoid.mappend` createCookieJar [c2])+ where c1 = default_cookie {cookie_creation_time = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 1)}+ c2 = default_cookie {cookie_creation_time = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 2)}+ cct cj = cookie_creation_time $ head $ destroyCookieJar cj++ipParseTests :: Spec+ipParseTests = do+ it "Valid IP" testValidIp+ it "Digit Too High" testIpNumTooHigh+ it "Too Many Segments" testTooManySegmentsInIp+ it "Chars in IP" testCharsInIp++domainMatchingTests :: Spec+domainMatchingTests = do+ it "Should Match" testDomainMatchesSuccess+ it "Same Domain" testSameDomain+ it "Sibling Domain" testSiblingDomain+ it "Parent Domain" testParentDomain+ it "Checking for Naive suffix-check" testNaiveSuffixDomain++defaultPathTests :: Spec+defaultPathTests = do+ it "Basic default path test" testDefaultPath+ it "Basic populated default path" testPopulatedDefaultPath+ it "Default path from request with GET params works" testParamsDefaultPath+ it "Getting a default path that ends in a slash" testDefaultPathEndingInSlash+ it "Getting a short default path" testShortDefaultPath++pathMatchingTests :: Spec+pathMatchingTests = do+ it "Same paths match" testSamePathsMatch+ it "Putting slash at end" testPathSlashAtEnd+ it "Not putting slash at end" testPathNoSlashAtEnd+ it "Diverging paths don't match" testDivergingPaths++equalityTests :: Spec+equalityTests = do+ it "The same cookie should be equal to itself" testCookieEqualitySuccess+ it "Changing extra options shouldn't change equality" testCookieEqualityResiliance+ it "Changing a cookie's domain should change its equality" testDomainChangesEquality++removeTests :: Spec+removeTests = do+ it "Removing a cookie works" testRemoveCookie+ it "Removing a nonexistent cookie doesn't work" testRemoveNonexistantCookie+ it "Removing the correct cookie" testRemoveCorrectCookie++evictionTests :: Spec+evictionTests = do+ it "Testing eviction" testEvictExpiredCookies+ it "Evicting from empty cookie jar" testEvictNoCookies++sendingTests :: Spec+sendingTests = do+ it "Updates last access time upon using cookies" testComputeCookieStringUpdateLastAccessTime+ it "Host-only flag matches exact host" testComputeCookieStringHostOnly+ it "Host-only flag doesn't match subdomain" testComputeCookieStringHostOnlyFilter+ it "Domain matching works properly" testComputeCookieStringDomainMatching+ it "Path matching works" testComputeCookieStringPathMatching+ it "Path matching fails when it should" testComputeCookieStringPathMatchingFails+ it "Path matching succeeds when request has GET params" testComputeCookieStringPathMatchingWithParms+ it "Secure flag filters correctly" testComputeCookieStringSecure+ it "Http-only flag filters correctly" testComputeCookieStringHttpOnly+ it "Sorting works correctly" testComputeCookieStringSort+ it "Inserting cookie header works" testInsertCookiesIntoRequestWorks++receivingTests :: Spec+receivingTests = do+ it "Can receive set-cookie" testReceiveSetCookie+ it "Receiving a Set-Cookie with a trailing dot on the domain" testReceiveSetCookieTrailingDot+ it "Receiving a Set-Cookie with a leading dot on the domain" testReceiveSetCookieLeadingDot+ it "Set-Cookie with no domain" testReceiveSetCookieNoDomain+ it "Set-Cookie with empty domain" testReceiveSetCookieEmptyDomain+ it "Set-Cookie with non-matching domain" testReceiveSetCookieNonMatchingDomain+ it "Host-only flag gets set" testReceiveSetCookieHostOnly+ it "Host-only flag doesn't get set" testReceiveSetCookieHostOnlyNotSet+ it "Http-only flag gets set" testReceiveSetCookieHttpOnly+ it "Http-only flag doesn't get set" testReceiveSetCookieHttpOnlyNotSet+ it "Checking non http request gets dropped" testReceiveSetCookieHttpOnlyDrop+ it "Name gets set correctly" testReceiveSetCookieName+ it "Value gets set correctly" testReceiveSetCookieValue+ it "Expiry gets set correctly" testReceiveSetCookieExpiry+ it "Expiry gets set based on max age if no expiry is given" testReceiveSetCookieNoExpiry+ it "Expiry gets set based on given value if no max age is given" testReceiveSetCookieNoMaxAge+ it "Expiry gets set to a future date if no expiry and no max age are given" testReceiveSetCookieNoExpiryNoMaxAge+ it "Path gets set correctly when nonexistent" testReceiveSetCookieNoPath+ it "Path gets set correctly" testReceiveSetCookiePath+ it "Creation time gets set correctly" testReceiveSetCookieCreationTime+ it "Last access time gets set correctly" testReceiveSetCookieAccessTime+ it "Persistent flag gets set correctly" testReceiveSetCookiePersistent+ it "Existing cookie gets updated" testReceiveSetCookieExisting+ it "Creation time gets updated in existing cookie" testReceiveSetCookieExistingCreation+ it "Existing http-only cookie gets dropped" testReceiveSetCookieExistingHttpOnly+ it "Secure flag gets set correctly" testReceiveSetCookieSecure+ it "Max-Age flag gets set correctly" testReceiveSetCookieMaxAge+ it "Max-Age is preferred over Expires" testReceiveSetCookiePreferMaxAge++monoidTests :: Spec+monoidTests = do+ it "Monoid prefers more recent cookies" testMonoidPreferRecent++cookieTest :: Spec+cookieTest = do+ describe "ipParseTests" ipParseTests+ describe "domainMatchingTests" domainMatchingTests+ describe "defaultPathTests" defaultPathTests+ describe "pathMatchingTests" pathMatchingTests+ describe "equalityTests" equalityTests+ describe "removeTests" removeTests+ describe "evictionTests" evictionTests+ describe "sendingTests" sendingTests+ describe "receivingTests" receivingTests+ describe "monoidTest" monoidTests
test/main.hs view
@@ -1,164 +1,538 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}-import Test.Hspec.Monadic+import Test.Hspec import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8-import Test.Hspec.HUnit ()+import qualified Data.ByteString.Lazy.Char8 as L8 import Test.HUnit import Network.Wai hiding (requestBody)-import qualified Network.Wai-import Network.Wai.Handler.Warp (run)-import Network.HTTP.Conduit-import Control.Concurrent (forkIO, killThread, threadDelay)+import Network.Wai.Conduit (responseSource, sourceRequestBody)+import Network.HTTP.Client (streamFile)+import System.IO.Temp (withSystemTempFile)+import qualified Network.Wai as Wai+import Network.Wai.Handler.Warp (runSettings, defaultSettings, setPort, setBeforeMainLoop, Settings, setTimeout)+import Network.HTTP.Conduit hiding (port)+import qualified Network.HTTP.Conduit as NHC+import Network.HTTP.Client.MultipartFormData+import Control.Concurrent (forkIO, killThread, putMVar, takeMVar, newEmptyMVar, threadDelay) import Network.HTTP.Types-import Control.Exception.Lifted (try, SomeException)-import Network.HTTP.Conduit.ConnInfo+import UnliftIO.Exception (try, SomeException, bracket, onException, IOException)+import qualified Data.IORef as I+import qualified Control.Exception as E (catch)+import qualified Network.Socket as NS import CookieTest (cookieTest)-import Data.Conduit.Network (runTCPServer, ServerSettings (..), HostPreference (HostAny))-import Data.Conduit (($$))-import Control.Monad.Trans.Resource (register)+#if MIN_VERSION_conduit(1,1,0)+import Data.Conduit.Network (runTCPServer, serverSettings, appSink, appSource, ServerSettings)+import Data.Streaming.Network (bindPortTCP, setAfterBind)+#define bindPort bindPortTCP+#else+import Data.Conduit.Network (runTCPServer, serverSettings, HostPreference (..), appSink, appSource, bindPort, serverAfterBind, ServerSettings)+#endif+import qualified Data.Conduit.Network+import System.IO.Unsafe (unsafePerformIO)+import Data.Conduit ((.|), yield, Flush (Chunk, Flush), await, runConduit)+import Control.Monad (void, forever) import Control.Monad.IO.Class (liftIO) import Data.ByteString.UTF8 (fromString) import Data.Conduit.List (sourceList) import Data.CaseInsensitive (mk) import Data.List (partition) import qualified Data.Conduit.List as CL+import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified Data.ByteString.Lazy as L import Blaze.ByteString.Builder (fromByteString)+import System.IO+import Data.Time.Clock+import Data.Time.Calendar+import qualified Network.Wai.Handler.WarpTLS as WT+import Network.Connection (settingDisableCertificateValidation)+import Data.Default (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) -app :: Application+past :: UTCTime+past = UTCTime (ModifiedJulianDay 56200) (secondsToDiffTime 0)++future :: UTCTime+future = UTCTime (ModifiedJulianDay 562000) (secondsToDiffTime 0)++cookie :: Cookie+cookie = Cookie { cookie_name = "key"+ , cookie_value = "value"+ , cookie_expiry_time = future+ , cookie_domain = "127.0.0.1"+ , cookie_path = "/dump_cookies"+ , cookie_creation_time = past+ , cookie_last_access_time = past+ , cookie_persistent = False+ , cookie_host_only = False+ , cookie_secure_only = False+ , cookie_http_only = False+ }++cookie_jar :: CookieJar+cookie_jar = createCookieJar [cookie]++app :: Wai.Request -> IO Wai.Response app req = case pathInfo req of- [] -> return $ responseLBS status200 [] "homepage"+ [] ->+ if maybe False ("example.com:" `S.isPrefixOf`) $ lookup "host" $ Wai.requestHeaders req+ then return $ responseLBS status200 [] "homepage for example.com"+ else return $ responseLBS status200 [] "homepage" ["cookies"] -> return $ responseLBS status200 [tastyCookie] "cookies"+ ["cookie_redir1"] -> return $ responseLBS status303 [tastyCookie, (hLocation, "/checkcookie")] ""+ ["checkcookie"] -> return $ case lookup hCookie $ Wai.requestHeaders req of+ Just "flavor=chocolate-chip" -> responseLBS status200 [] "nom-nom-nom"+ _ -> responseLBS status412 [] "Baaaw where's my chocolate?"+ ["infredir", i'] ->+ let i = read $ T.unpack i' :: Int+ in return $ responseLBS status303+ [(hLocation, S.append "/infredir/" $ S8.pack $ show $ i+1)]+ (L8.pack $ show i)+ ["dump_cookies"] -> return $ responseLBS status200 [] $ L.fromChunks $ return $ maybe "" id $ lookup hCookie $ Wai.requestHeaders req+ ["delayed"] -> return $ responseSource status200 [("foo", "bar")] $ do+ yield Flush+ liftIO $ threadDelay 30000000+ yield $ Chunk $ fromByteString "Hello World!" _ -> return $ responseLBS status404 [] "not found" where tastyCookie = (mk (fromString "Set-Cookie"), fromString "flavor=chocolate-chip;") +nextPort :: I.IORef Int+nextPort = unsafePerformIO $ I.newIORef 15452+{-# NOINLINE nextPort #-}++getPort :: IO Int+getPort = do+ port <- I.atomicModifyIORef nextPort $ \p -> (p + 1, p + 1)+ esocket <- try $ bindPort port "*4"+ case esocket of+ Left (_ :: IOException) -> getPort+ Right socket -> do+ NS.close socket+ return port++withApp :: (Wai.Request -> IO Wai.Response) -> (Int -> IO ()) -> IO ()+withApp app' f = withApp' (const app') f++withApp' :: (Int -> Wai.Request -> IO Wai.Response) -> (Int -> IO ()) -> IO ()+withApp' = withAppSettings id++withAppSettings :: (Settings -> Settings)+ -> (Int -> Wai.Request -> IO Wai.Response)+ -> (Int -> IO ())+ -> IO ()+withAppSettings modSettings app' f = do+ port <- getPort+ baton <- newEmptyMVar+ bracket+ (forkIO $ runSettings (modSettings $+ setPort port+ $ setBeforeMainLoop (putMVar baton ())+ defaultSettings) (app'' port) `onException` putMVar baton ())+ killThread+ (const $ takeMVar baton >> f port)+ where+ app'' port req sendResponse = do+ res <- app' port req+ sendResponse res++withAppTls :: (Wai.Request -> IO Wai.Response) -> (Int -> IO ()) -> IO ()+withAppTls app' f = withAppTls' (const app') f++withAppTls' :: (Int -> Wai.Request -> IO Wai.Response) -> (Int -> IO ()) -> IO ()+withAppTls' app' f = do+ port <- getPort+ baton <- newEmptyMVar+ bracket+ (forkIO $ WT.runTLS WT.defaultTlsSettings (+ setPort port+ $ setBeforeMainLoop (putMVar baton ())+ defaultSettings)+ (app'' port) `onException` putMVar baton ())+ killThread+ (const $ takeMVar baton >> f port)+ where+ app'' port req sendResponse = do+ res <- app' port req+ sendResponse res+ main :: IO ()-main = hspecX $ do+main = do+ mapM_ (`hSetBuffering` LineBuffering) [stdout, stderr]+ hspec $ do cookieTest describe "simpleHttp" $ do- it "gets homepage" $ do- tid <- forkIO $ run 3000 app- lbs <- simpleHttp "http://127.0.0.1:3000/"- killThread tid+ it "gets homepage" $ withApp app $ \port -> do+ lbs <- simpleHttp $ "http://127.0.0.1:" ++ show port lbs @?= "homepage"- it "throws exception on 404" $ do- tid <- forkIO $ run 3001 app- elbs <- try $ simpleHttp "http://127.0.0.1:3001/404"- killThread tid+ 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" $ do- tid <- forkIO $ run 3010 app- request <- parseUrl "http://127.0.0.1:3010/cookies"- withManager $ \manager -> do- Response _ _ headers _ <- httpLbs request manager- let setCookie = mk (fromString "Set-Cookie")- (setCookieHeaders, _) = partition ((== setCookie) . fst) headers- liftIO $ assertBool "response contains a 'set-cookie' header" $ length setCookieHeaders > 0- killThread tid+ it "preserves 'set-cookie' headers" $ withApp app $ \port -> do+ request <- parseUrlThrow $ concat ["http://127.0.0.1:", show port, "/cookies"]+ manager <- newManager tlsManagerSettings+ response <- httpLbs request manager+ let setCookie = mk (fromString "Set-Cookie")+ (setCookieHeaders, _) = partition ((== setCookie) . fst) (NHC.responseHeaders response)+ assertBool "response contains a 'set-cookie' header" $ length setCookieHeaders > 0+ it "redirects set cookies" $ withApp app $ \port -> do+ request <- parseUrlThrow $ concat ["http://127.0.0.1:", show port, "/cookie_redir1"]+ manager <- newManager tlsManagerSettings+ response <- httpLbs request manager+ (responseBody response) @?= "nom-nom-nom"+ it "user-defined cookie jar works" $ withApp app $ \port -> do+ request <- parseUrlThrow $ concat ["http://127.0.0.1:", show port, "/dump_cookies"]+ manager <- newManager tlsManagerSettings+ response <- httpLbs (request {redirectCount = 1, cookieJar = Just cookie_jar}) manager+ (responseBody response) @?= "key=value"+ it "user-defined cookie jar is not ignored when redirection is disabled" $ withApp app $ \port -> do+ request <- parseUrlThrow $ concat ["http://127.0.0.1:", show port, "/dump_cookies"]+ manager <- newManager tlsManagerSettings+ response <- httpLbs (request {redirectCount = 0, cookieJar = Just cookie_jar}) manager+ (responseBody response) @?= "key=value"+ it "cookie jar is available in response" $ withApp app $ \port -> do+ request <- parseUrlThrow $ concat ["http://127.0.0.1:", show port, "/cookies"]+ manager <- newManager tlsManagerSettings+ response <- httpLbs (request {cookieJar = Just Data.Monoid.mempty}) manager+ (length $ destroyCookieJar $ responseCookieJar response) @?= 1+ it "Cookie header isn't touched when no cookie jar supplied" $ withApp app $ \port -> do+ request <- parseUrlThrow $ concat ["http://127.0.0.1:", show port, "/dump_cookies"]+ manager <- newManager tlsManagerSettings+ let request_headers = (mk "Cookie", "key2=value2") : filter ((/= mk "Cookie") . fst) (NHC.requestHeaders request)+ response <- httpLbs (request {NHC.requestHeaders = request_headers, cookieJar = Nothing}) manager+ (responseBody response) @?= "key2=value2"+ it "Response cookie jar is nothing when request cookie jar is nothing" $ withApp app $ \port -> do+ request <- parseUrlThrow $ concat ["http://127.0.0.1:", show port, "/cookies"]+ manager <- newManager tlsManagerSettings+ response <- httpLbs (request {cookieJar = Nothing}) manager+ (responseCookieJar response) @?= mempty+ it "TLS" $ withAppTls app $ \port -> do+ request <- parseUrlThrow $ "https://127.0.0.1:" ++ show port+ let set = mkManagerSettings+ def+ { settingDisableCertificateValidation = True+ }+ Nothing+ manager <- newManager set+ response <- httpLbs request manager+ responseBody response @?= "homepage" describe "manager" $ do- it "closes all connections" $ do- clearSocketsList- tid1 <- forkIO $ run 3002 app- tid2 <- forkIO $ run 3003 app- threadDelay 1000- withManager $ \manager -> do- let Just req1 = parseUrl "http://127.0.0.1:3002/"- let Just req2 = parseUrl "http://127.0.0.1:3003/"+ it "closes all connections" $ withApp app $ \port1 -> withApp app $ \port2 -> do+ --FIXME clearSocketsList+ manager <- newManager tlsManagerSettings+ let Just req1 = parseUrlThrow $ "http://127.0.0.1:" ++ show port1+ let Just req2 = parseUrlThrow $ "http://127.0.0.1:" ++ show port2+ runResourceT $ do _res1a <- http req1 manager _res1b <- http req1 manager _res2 <- http req2 manager return ()- requireAllSocketsClosed- killThread tid2- killThread tid1+ --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" $ do- tid1 <- forkIO overLongHeaders- threadDelay 1000- withManager $ \manager -> do- _ <- register $ killThread tid1- let Just req1 = parseUrl "http://127.0.0.1:3004/"- res1 <- try $ http req1 manager- case res1 of- Left e -> liftIO $ show (e :: SomeException) @?= show OverlongHeaders- _ -> error "Shouldn't have worked"- it "not overlong headers" $ do- tid1 <- forkIO notOverLongHeaders- threadDelay 1000- withManager $ \manager -> do- _ <- register $ killThread tid1- let Just req1 = parseUrl "http://127.0.0.1:3005/"- _ <- httpLbs req1 manager- return ()+ it "overlong headers" $ overLongHeaders $ \port -> do+ manager <- newManager tlsManagerSettings+ let Just req1 = parseUrlThrow $ "http://127.0.0.1:" ++ show port+ res1 <- try $ runResourceT $ http req1 manager+ case res1 of+ Left e -> show (e :: SomeException) @?= show (HttpExceptionRequest req1 OverlongHeaders)+ _ -> error "Shouldn't have worked"+ it "not overlong headers" $ notOverLongHeaders $ \port -> do+ manager <- newManager tlsManagerSettings+ let Just req1 = parseUrlThrow $ "http://127.0.0.1:" ++ show port+ _ <- httpLbs req1 manager+ return () describe "redirects" $ do- it "doesn't double escape" $ do- tid <- forkIO redir- threadDelay 1000000- withManager $ \manager -> do- _ <- register $ killThread tid- let go (encoded, final) = do- let Just req1 = parseUrl $ "http://127.0.0.1:3006/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 "doesn't double escape" $ redir $ \port -> do+ manager <- newManager tlsManagerSettings+ let go (encoded, final) = do+ let Just req1 = parseUrlThrow $ concat ["http://127.0.0.1:", show port, "/redir/", encoded]+ res <- httpLbs req1 manager+ liftIO $ Network.HTTP.Conduit.responseStatus res @?= status200+ liftIO $ responseBody res @?= L.fromChunks [TE.encodeUtf8 final]+ mapM_ go+ [ ("hello world%2F", "hello world/")+ , ("%D7%A9%D7%9C%D7%95%D7%9D", "שלום")+ , ("simple", "simple")+ , ("hello%20world", "hello world")+ , ("hello%20world%3f%23", "hello world?#")+ ]+ it "TooManyRedirects: redirect request body is preserved" $ withApp app $ \port -> do+ let Just req = parseUrlThrow $ concat ["http://127.0.0.1:", show port, "/infredir/0"]+ let go (res, i) = liftIO $ responseBody res @?= (L8.pack $ show i)+ manager <- newManager tlsManagerSettings+ E.catch (void $ runResourceT $ http req{redirectCount=5} manager)+ $ \e ->+ case e of+ HttpExceptionRequest _ (TooManyRedirects redirs) ->+ mapM_ go (zip redirs [5,4..0 :: Int])+ _ -> error $ show e describe "chunked request body" $ do- it "works" $ do- tid <- forkIO echo- threadDelay 1000000- withManager $ \manager -> do- _ <- register $ killThread tid- let go bss = do- let Just req1 = parseUrl "http://127.0.0.1:3007"- 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"+ it "works" $ echo $ \port -> do+ manager <- newManager tlsManagerSettings+ let go bss = do+ let Just req1 = parseUrlThrow $ "POST http://127.0.0.1:" ++ show port+ src = sourceList bss+ lbs = L.fromChunks bss+ res <- httpLbs req1+ { requestBody = requestBodySourceChunked src+ } manager+ liftIO $ Network.HTTP.Conduit.responseStatus res @?= status200+ let ts = S.concat . L.toChunks+ liftIO $ ts (responseBody res) @?= ts lbs+ mapM_ go+ [ ["hello", "world"]+ , replicate 500 "foo\003\n\r"+ ]+ describe "no status message" $ do+ it "works" $ noStatusMessage $ \port -> do+ req <- parseUrlThrow $ "http://127.0.0.1:" ++ show port+ manager <- newManager tlsManagerSettings+ res <- httpLbs req manager+ liftIO $ do+ Network.HTTP.Conduit.responseStatus res `shouldBe` status200+ responseBody res `shouldBe` "foo"++ describe "response body too short" $ do+ it "throws an exception" $ wrongLength $ \port -> do+ req <- parseUrlThrow $ "http://127.0.0.1:" ++ show port+ manager <- newManager tlsManagerSettings+ eres <- try $ httpLbs req manager+ liftIO $ either (Left . (show :: HttpException -> String)) (Right . id) eres+ `shouldBe` Left (show $ HttpExceptionRequest req $ ResponseBodyTooShort 50 18)++ describe "chunked response body" $ do+ it "no chunk terminator" $ wrongLengthChunk1 $ \port -> do+ req <- parseUrlThrow $ "http://127.0.0.1:" ++ show port+ manager <- newManager tlsManagerSettings+ eres <- try $ httpLbs req manager+ liftIO $ either (Left . (show :: HttpException -> String)) (Right . id) eres+ `shouldBe` Left (show (HttpExceptionRequest req IncompleteHeaders))+ it "incomplete chunk" $ wrongLengthChunk2 $ \port -> do+ req <- parseUrlThrow $ "http://127.0.0.1:" ++ show port+ manager <- newManager tlsManagerSettings+ eres <- try $ httpLbs req manager+ liftIO $ either (Left . (show :: HttpException -> String)) (Right . id) eres+ `shouldBe` Left (show (HttpExceptionRequest req InvalidChunkHeaders))+ it "invalid chunk" $ invalidChunk $ \port -> do+ req <- parseUrlThrow $ "http://127.0.0.1:" ++ show port+ manager <- newManager tlsManagerSettings+ eres <- try $ httpLbs req manager+ liftIO $ either (Left . (show :: HttpException -> String)) (Right . id) eres+ `shouldBe` Left (show (HttpExceptionRequest req InvalidChunkHeaders))++ it "missing header" $ rawApp+ "HTTP/1.1 200 OK\r\nTransfer-Encoding: chunked\r\n\r\n4\r\nabcd\r\n\r\n\r\n"+ $ \port -> do+ req <- parseUrlThrow $ "http://127.0.0.1:" ++ show port+ manager <- newManager tlsManagerSettings+ eres <- try $ httpLbs req manager+ liftIO $ either (Left . (show :: HttpException -> String)) (Right . id) eres+ `shouldBe` Left (show (HttpExceptionRequest req InvalidChunkHeaders))++ it "junk header" $ rawApp+ "HTTP/1.1 200 OK\r\nTransfer-Encoding: chunked\r\n\r\n4\r\nabcd\r\njunk\r\n\r\n"+ $ \port -> do+ req <- parseUrlThrow $ "http://127.0.0.1:" ++ show port+ manager <- newManager tlsManagerSettings+ eres <- try $ httpLbs req manager+ liftIO $ either (Left . (show :: HttpException -> String)) (Right . id) eres+ `shouldBe` Left (show (HttpExceptionRequest req InvalidChunkHeaders))++ describe "redirect" $ do+ it "ignores large response bodies" $ do+ let app' port req =+ case pathInfo req of+ ["foo"] -> return $ responseLBS status200 [] "Hello World!"+ _ -> return $ responseSource status301 [("location", S8.pack $ "http://127.0.0.1:" ++ show port ++ "/foo")] $ forever $ yield $ Chunk $ fromByteString "hello\n"+ manager <- newManager tlsManagerSettings+ withApp' app' $ \port -> do+ req <- liftIO $ parseUrlThrow $ "http://127.0.0.1:" ++ show port+ res <- httpLbs req manager+ liftIO $ do+ Network.HTTP.Conduit.responseStatus res `shouldBe` status200+ responseBody res `shouldBe` "Hello World!"+ describe "multipart/form-data" $ do+ it "formats correctly" $ do+ let bd = "---------------------------190723902820679116301912680260"+ (RequestBodyStream _ givesPopper) <- renderParts bd+ [partBS "email" ""+ ,partBS "parent_id" "70488"+ ,partBS "captcha" ""+ ,partBS "homeboard" "0chan.hk"+ ,partBS "text" $ TE.encodeUtf8 ">>72127\r\nМы работаем над этим."+ ,partFileSource "upload" "nyan.gif"+ ]+ ires <- I.newIORef S.empty+ let loop front popper = do+ bs <- popper+ if S.null bs+ then I.writeIORef ires $ S.concat $ front []+ else loop (front . (bs:)) popper+ givesPopper $ loop id+ mfd <- I.readIORef ires+ exam <- S.readFile "multipart-example.bin"+ mfd @?= exam++ describe "HTTP/1.0" $ do+ it "BaseHTTP" $ do+ let baseHTTP app' = do+ _ <- runConduit $ appSource app' .| await+ runConduit $ yield "HTTP/1.0 200 OK\r\n\r\nThis is it!" .| appSink app'+ manager <- newManager tlsManagerSettings+ withCApp baseHTTP $ \port -> do+ req <- liftIO $ parseUrlThrow $ "http://127.0.0.1:" ++ show port+ res1 <- httpLbs req manager+ res2 <- httpLbs req manager+ liftIO $ res1 @?= res2++ describe "hostAddress" $ do+ it "overrides host" $ withApp app $ \port -> do+ 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 <- parseUrlThrow $ "http://localhost:" ++ show port+ let req2 = req1 { responseTimeout = responseTimeoutMicro 5000000 }+ man <- newManager tlsManagerSettings { managerResponseTimeout = responseTimeoutMicro 1 }+ eres1 <- try $ httpLbs req1 { NHC.path = "/delayed" } man+ case eres1 of+ Left (HttpExceptionRequest _ ConnectionTimeout{}) -> return ()+ _ -> error "Did not time out"+ _ <- httpLbs req2 man+ return ()++ describe "delayed body" $ do+ it "works" $ withApp app $ \port -> do+ req <- parseUrlThrow $ "http://localhost:" ++ show port ++ "/delayed"+ man <- newManager tlsManagerSettings+ _ <- runResourceT $ http req man+ return ()++ it "reuse/connection close tries again" $ do+ withAppSettings (setTimeout 1) (const app) $ \port -> do+ req <- parseUrlThrow $ "http://localhost:" ++ show port+ man <- newManager tlsManagerSettings+ res1 <- httpLbs req man+ threadDelay 3000000+ res2 <- httpLbs req man+ let f res = res+ { NHC.responseHeaders = filter (not . isDate) (NHC.responseHeaders res)+ }+ isDate ("date", _) = True+ isDate _ = False+ f res2 `shouldBe` f res1++ it "setQueryString" $ do+ ref <- I.newIORef undefined+ let app' req = do+ I.writeIORef ref $ Wai.queryString req+ return $ responseLBS status200 [] ""+ withApp app' $ \port -> do+ let qs =+ [ ("foo", Just "bar")+ , (TE.encodeUtf8 "שלום", Just "hola")+ , ("noval", Nothing) ]+ man <- newManager tlsManagerSettings+ req <- parseUrlThrow $ "http://localhost:" ++ show port+ _ <- httpLbs (setQueryString qs req) man+ res <- I.readIORef ref+ res `shouldBe` qs -overLongHeaders :: IO ()-overLongHeaders = runTCPServer (ServerSettings 3004 HostAny) $ \_ sink ->- src $$ sink+#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 "*" :: ServerSettings IO) { serverAfterBind = const start }+#endif+ bracket+ (forkIO $ runTCPServer settings app' `onException` start)+ killThread+ (const $ takeMVar baton >> f port)++overLongHeaders :: (Int -> IO ()) -> IO ()+overLongHeaders =+ withCApp $ \app' -> runConduit $ src .| appSink app' where src = sourceList $ "HTTP/1.0 200 OK\r\nfoo: " : repeat "bar" -notOverLongHeaders :: IO ()-notOverLongHeaders = runTCPServer (ServerSettings 3005 HostAny) $ \src' sink -> do- src' $$ CL.drop 1- src $$ sink+notOverLongHeaders :: (Int -> IO ()) -> IO ()+notOverLongHeaders = withCApp $ \app' -> do+ runConduit $ appSource app' .| CL.drop 1+ runConduit $ src .| appSink app' where src = sourceList $ [S.concat $ "HTTP/1.0 200 OK\r\nContent-Type: text/plain\r\nContent-Length: 16384\r\n\r\n" : ( take 16384 $ repeat "x")] -redir :: IO ()+redir :: (Int -> IO ()) -> IO () redir =- run 3006 redirApp+ withApp' redirApp where- redirApp req =+ redirApp port req = case pathInfo req of ["redir", foo] -> return $ responseLBS status301- [ ("Location", "http://127.0.0.1:3006/content/" `S.append` escape foo)+ [ ("Location", S8.pack (concat ["http://127.0.0.1:", show port, "/content/"]) `S.append` escape foo) ] "" ["content", foo] -> return $ responseLBS status200 [] $ L.fromChunks [TE.encodeUtf8 foo]@@ -185,7 +559,73 @@ | otherwise = error $ "Invalid argument to showHex: " ++ show x in ['%', showHex' b, showHex' c] -echo :: IO ()-echo = run 3007 $ \req -> do- bss <- Network.Wai.requestBody req $$ CL.consume+echo :: (Int -> IO ()) -> IO ()+echo = withApp $ \req -> do+ bss <- runConduit $ sourceRequestBody req .| CL.consume return $ responseLBS status200 [] $ L.fromChunks bss++noStatusMessage :: (Int -> IO ()) -> IO ()+noStatusMessage =+ withCApp $ \app' -> runConduit $ src .| appSink app'+ where+ src = yield "HTTP/1.0 200\r\nContent-Length: 3\r\n\r\nfoo: barbazbin"++wrongLength :: (Int -> IO ()) -> IO ()+wrongLength =+ withCApp $ \app' -> do+ _ <- runConduit $ appSource app' .| await+ runConduit $ src .| appSink app'+ where+ src = do+ yield "HTTP/1.0 200 OK\r\nContent-Length: 50\r\n\r\n"+ yield "Not quite 50 bytes"++wrongLengthChunk1 :: (Int -> IO ()) -> IO ()+wrongLengthChunk1 =+ withCApp $ \app' -> do+ _ <- runConduit $ appSource app' .| await+ runConduit $ src .| appSink app'+ where+ src = yield "HTTP/1.1 200 OK\r\nTransfer-Encoding: chunked\r\n\r\n4\r\nWiki\r\n"++wrongLengthChunk2 :: (Int -> IO ()) -> IO ()+wrongLengthChunk2 =+ withCApp $ \app' -> do+ _ <- runConduit $ appSource app' .| await+ runConduit $ src .| appSink app'+ where+ src = yield "HTTP/1.1 200 OK\r\nTransfer-Encoding: chunked\r\n\r\n4\r\nWiki\r\n5\r\npedia\r\nE\r\nin\r\n\r\nch\r\n"++invalidChunk :: (Int -> IO ()) -> IO ()+invalidChunk =+ withCApp $ \app' -> do+ _ <- runConduit $ appSource app' .| await+ runConduit $ src .| appSink app'+ where+ src = yield "HTTP/1.1 200 OK\r\nTransfer-Encoding: chunked\r\n\r\n4\r\nabcd\r\ngarbage\r\nef\r\n0\r\n\r\n"++rawApp :: S8.ByteString -> (Int -> IO ()) -> IO ()+rawApp bs =+ withCApp $ \app' -> do+ _ <- runConduit $ appSource app' .| await+ runConduit $ src .| appSink app'+ where+ src = yield bs++#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