diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -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` diff --git a/Network/HTTP/Client/Conduit.hs b/Network/HTTP/Client/Conduit.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Client/Conduit.hs @@ -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: +-- +-- +-- +-- 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 diff --git a/Network/HTTP/Conduit.hs b/Network/HTTP/Conduit.hs --- a/Network/HTTP/Conduit.hs +++ b/Network/HTTP/Conduit.hs @@ -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: +-- +-- +-- +-- = 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,39 +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 -- --- 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: +-- Note: In previous versions, the Host header would be set by this module in +-- all cases. Starting from 1.6.1, if a Host header is present in +-- @requestHeaders@, it will be used in place of the header this module would +-- have generated. This can be useful for calling a server which utilizes +-- virtual hosting. -- +-- Use `cookieJar` If you want to supply cookies with your request: +-- +-- > {-# LANGUAGE OverloadedStrings #-} -- > import Network.HTTP.Conduit --- > import 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.: @@ -58,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 @@ -71,10 +144,8 @@ -- * Datatypes , Proxy (..) , RequestBody (..) - , Response (..) -- ** Request , Request - , def , method , secure , host @@ -84,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 @@ -122,116 +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.ResumableSource 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 - let CI.ResumableSource _ final = body - final - 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.ResumableSource 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'. -- @@ -240,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 @@ -248,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 diff --git a/Network/HTTP/Conduit/Browser.hs b/Network/HTTP/Conduit/Browser.hs deleted file mode 100644 --- a/Network/HTTP/Conduit/Browser.hs +++ /dev/null @@ -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 (ResumableSource (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} diff --git a/Network/HTTP/Conduit/Chunk.hs b/Network/HTTP/Conduit/Chunk.hs deleted file mode 100644 --- a/Network/HTTP/Conduit/Chunk.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -module Network.HTTP.Conduit.Chunk - ( chunkedConduit - , chunkIt - ) where - -import Numeric (showHex) - -import qualified Data.ByteString as S -import qualified Data.ByteString.Char8 as S8 - -import Blaze.ByteString.Builder.HTTP -import qualified Blaze.ByteString.Builder as Blaze - -import Data.Conduit hiding (Source, Sink, Conduit) -import qualified Data.Conduit.Binary as CB - -import Control.Monad (when, unless) -import Control.Exception (assert) - -chunkedConduit :: MonadThrow m - => Bool -- ^ send the headers as well, necessary for a proxy - -> Pipe S.ByteString S.ByteString S.ByteString u m () -chunkedConduit sendHeaders = do - i <- getLen - when sendHeaders $ yield $ S8.pack $ showHex i "\r\n" - unless (i == 0) $ do - CB.isolate i - CB.drop 2 - chunkedConduit sendHeaders - -getLen :: Monad m => Pipe S.ByteString S.ByteString o u m Int -getLen = - start 0 - where - start i = await >>= maybe (return i) (go i) - - go i bs = - case S.uncons bs of - Nothing -> start i - Just (w, bs') -> - case toI w of - Just i' -> go (i * 16 + i') bs' - Nothing -> do - stripNewLine bs - return i - - stripNewLine bs = - case S.uncons $ S.dropWhile (/= 10) bs of - Just (10, bs') -> leftover bs' - Just _ -> assert False $ await >>= maybe (return ()) stripNewLine - Nothing -> await >>= maybe (return ()) stripNewLine - - toI w - | 48 <= w && w <= 57 = Just $ fromIntegral w - 48 - | 65 <= w && w <= 70 = Just $ fromIntegral w - 55 - | 97 <= w && w <= 102 = Just $ fromIntegral w - 87 - | otherwise = Nothing - -chunkIt :: Monad m => Pipe l Blaze.Builder Blaze.Builder r m r -chunkIt = - awaitE >>= either - (\u -> yield chunkedTransferTerminator >> return u) - (\x -> yield (chunkedTransferEncoding x) >> chunkIt) diff --git a/Network/HTTP/Conduit/ConnInfo.hs b/Network/HTTP/Conduit/ConnInfo.hs deleted file mode 100644 --- a/Network/HTTP/Conduit/ConnInfo.hs +++ /dev/null @@ -1,170 +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 Data.Conduit hiding (Source, Sink, Conduit) - -#if DEBUG -import qualified Data.IntMap as IntMap -import qualified Data.IORef as I -import System.IO.Unsafe (unsafePerformIO) -#endif - -data ConnInfo = ConnInfo - { connRead :: IO ByteString - , connWrite :: ByteString -> IO () - , connClose :: IO () - } - -connSink :: MonadResource m => ConnInfo -> Pipe l ByteString o r m r -connSink ConnInfo { connWrite = write } = - self - where - self = awaitE >>= either return (\x -> liftIO (write x) >> self) - -connSource :: MonadResource m => ConnInfo -> Pipe l i ByteString u m () -connSource ConnInfo { connRead = read' } = - self - where - self = do - bs <- liftIO read' - if S.null bs - then return () - else yield bs >> self - -#if DEBUG -allOpenSockets :: I.IORef (Int, IntMap.IntMap String) -allOpenSockets = unsafePerformIO $ I.newIORef (0, IntMap.empty) - -addSocket :: String -> IO Int -addSocket desc = I.atomicModifyIORef allOpenSockets $ \(next, m) -> - ((next + 1, IntMap.insert next desc m), next) - -removeSocket :: Int -> IO () -removeSocket i = I.atomicModifyIORef allOpenSockets $ \(next, m) -> - ((next, IntMap.delete i m), ()) - -printOpenSockets :: IO () -printOpenSockets = do - (_, m) <- I.readIORef allOpenSockets - putStrLn "\n\nOpen sockets:" - if IntMap.null m - then putStrLn "** No open sockets!" - else mapM_ putStrLn $ IntMap.elems m - -requireAllSocketsClosed :: IO () -requireAllSocketsClosed = do - (_, m) <- I.readIORef allOpenSockets - if IntMap.null m - then return () - else error $ unlines - $ "requireAllSocketsClosed: there are open sockets" - : IntMap.elems m - -clearSocketsList :: IO () -clearSocketsList = I.writeIORef allOpenSockets (0, IntMap.empty) -#endif - -socketConn :: String -> Socket -> IO ConnInfo -socketConn _desc sock = do -#if DEBUG - i <- addSocket _desc -#endif - return ConnInfo - { connRead = recv sock 4096 - , connWrite = sendAll sock - , connClose = do -#if DEBUG - removeSocket i -#endif - sClose sock - } - -sslClientConn :: String -> ([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 diff --git a/Network/HTTP/Conduit/Cookies.hs b/Network/HTTP/Conduit/Cookies.hs deleted file mode 100644 --- a/Network/HTTP/Conduit/Cookies.hs +++ /dev/null @@ -1,265 +0,0 @@ --- | This module implements the algorithms described in RFC 6265 for the Network.HTTP.Conduit library. -module Network.HTTP.Conduit.Cookies where - -import qualified Data.ByteString as BS -import qualified Data.ByteString.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 :: BS.ByteString -> Bool -isIpAddress a = case strs of - Just strs' -> helper strs' - Nothing -> False - where s = U.toString a - regex = mkRegex "^([0-9]{1,3})\\.([0-9]{1,3})\\.([0-9]{1,3})\\.([0-9]{1,3})$" - strs = matchRegex regex s - helper l = length l == 4 && all helper2 l - helper2 v = (read v :: Int) >= 0 && (read v :: Int) < 256 - --- | This corresponds to the subcomponent algorithm entitled \"Domain Matching\" detailed --- in section 5.1.3 -domainMatches :: BS.ByteString -> BS.ByteString -> Bool -domainMatches string domainString - | string == domainString = True - | BS.length string < BS.length domainString + 1 = False - | domainString `BS.isSuffixOf` string && BS.singleton (BS.last difference) == U.fromString "." && not (isIpAddress string) = True - | otherwise = False - where difference = BS.take (BS.length string - BS.length domainString) string - --- | This corresponds to the subcomponent algorithm entitled \"Paths\" detailed --- in section 5.1.4 -defaultPath :: Req.Request m -> BS.ByteString -defaultPath req - | BS.null uri_path = U.fromString "/" - | BS.singleton (BS.head uri_path) /= U.fromString "/" = U.fromString "/" - | BS.count slash uri_path <= 1 = U.fromString "/" - | otherwise = BS.reverse $ BS.tail $ BS.dropWhile (/= slash) $ BS.reverse uri_path - where uri_path = Req.path req - --- | This corresponds to the subcomponent algorithm entitled \"Path-Match\" detailed --- in section 5.1.4 -pathMatches :: BS.ByteString -> BS.ByteString -> Bool -pathMatches requestPath cookiePath - | cookiePath == 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 :: BS.ByteString - , cookie_value :: BS.ByteString - , cookie_expiry_time :: UTCTime - , cookie_domain :: BS.ByteString - , cookie_path :: BS.ByteString - , cookie_creation_time :: UTCTime - , cookie_last_access_time :: UTCTime - , cookie_persistent :: Bool - , cookie_host_only :: Bool - , cookie_secure_only :: Bool - , cookie_http_only :: Bool - } - deriving (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 :: BS.ByteString -> 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) - -> (BS.ByteString, CookieJar) -- ^ (Contents of a \"Cookie\" header, Updated cookie jar (last-access-time is updated)) -computeCookieString request cookie_jar now is_http_api = (output_line, cookie_jar') - where matching_cookie cookie = condition1 && condition2 && condition3 && condition4 - where condition1 - | cookie_host_only cookie = Req.host request == cookie_domain cookie - | otherwise = domainMatches (Req.host request) (cookie_domain cookie) - condition2 = pathMatches (Req.path request) (cookie_path cookie) - condition3 - | not (cookie_secure_only cookie) = True - | otherwise = Req.secure request - condition4 - | not (cookie_http_only cookie) = True - | otherwise = is_http_api - matching_cookies = filter matching_cookie $ expose cookie_jar - output_cookies = map (\ c -> (cookie_name c, cookie_value c)) $ L.sort matching_cookies - output_line = toByteString $ renderCookies $ output_cookies - folding_function cookie_jar'' cookie = case removeExistingCookieFromCookieJar cookie cookie_jar'' of - (Just c, cookie_jar''') -> insertIntoCookieJar (c {cookie_last_access_time = now}) cookie_jar''' - (Nothing, cookie_jar''') -> cookie_jar''' - cookie_jar' = foldl folding_function cookie_jar matching_cookies - --- | This applies 'receiveSetCookie' to a given Response -updateCookieJar :: Res.Response a -- ^ Response received from server - -> Req.Request m -- ^ Request which generated the response - -> UTCTime -- ^ Value that should be used as \"now\" - -> CookieJar -- ^ Current cookie jar - -> (CookieJar, Res.Response a) -- ^ (Updated cookie jar with cookies from the Response, The response stripped of any \"Set-Cookie\" header) -updateCookieJar response request now cookie_jar = (cookie_jar', response {Res.responseHeaders = other_headers}) - where (set_cookie_headers, other_headers) = L.partition ((== (CI.mk $ U.fromString "Set-Cookie")) . fst) $ Res.responseHeaders response - set_cookie_data = map snd set_cookie_headers - set_cookies = map parseSetCookie set_cookie_data - cookie_jar' = foldl (\ cj sc -> receiveSetCookie sc request now True cj) cookie_jar set_cookies - --- | This corresponds to the algorithm described in Section 5.3 \"Storage Model\" --- This function consists of calling 'generateCookie' followed by 'insertCheckedCookie'. --- Use this function if you plan to do both in a row. --- 'generateCookie' and 'insertCheckedCookie' are only provided for more fine-grained control. -receiveSetCookie :: SetCookie -- ^ The 'SetCookie' the cookie jar is receiving - -> Req.Request m -- ^ The request that originated the response that yielded the 'SetCookie' - -> UTCTime -- ^ Value that should be used as \"now\" - -> Bool -- ^ Whether or not this request is coming from an \"http\" source (not javascript or anything like that) - -> CookieJar -- ^ Input cookie jar to modify - -> CookieJar -- ^ Updated cookie jar -receiveSetCookie set_cookie request now is_http_api cookie_jar = case (do - cookie <- generateCookie set_cookie request now is_http_api - return $ insertCheckedCookie cookie cookie_jar is_http_api) of - Just cj -> cj - Nothing -> cookie_jar - --- | Insert a cookie created by generateCookie into the cookie jar (or not if it shouldn't be allowed in) -insertCheckedCookie :: Cookie -- ^ The 'SetCookie' the cookie jar is receiving - -> CookieJar -- ^ Input cookie jar to modify - -> Bool -- ^ Whether or not this request is coming from an \"http\" source (not javascript or anything like that) - -> CookieJar -- ^ Updated (or not) cookie jar -insertCheckedCookie c cookie_jar is_http_api = case (do - (cookie_jar', cookie') <- existanceTest c cookie_jar - return $ insertIntoCookieJar cookie' cookie_jar') of - Just cj -> cj - Nothing -> cookie_jar - where existanceTest cookie cookie_jar' = existanceTestHelper cookie $ removeExistingCookieFromCookieJar cookie cookie_jar' - existanceTestHelper new_cookie (Just old_cookie, cookie_jar') - | not is_http_api && cookie_http_only old_cookie = Nothing - | otherwise = return (cookie_jar', new_cookie {cookie_creation_time = cookie_creation_time old_cookie}) - existanceTestHelper new_cookie (Nothing, cookie_jar') = return (cookie_jar', new_cookie) - --- | Turn a SetCookie into a Cookie, if it is valid -generateCookie :: SetCookie -- ^ The 'SetCookie' we are encountering - -> Req.Request m -- ^ The request that originated the response that yielded the 'SetCookie' - -> UTCTime -- ^ Value that should be used as \"now\" - -> Bool -- ^ Whether or not this request is coming from an \"http\" source (not javascript or anything like that) - -> Maybe Cookie -- ^ The optional output cookie -generateCookie set_cookie request now is_http_api = do - domain_sanitized <- sanitizeDomain $ step4 (setCookieDomain set_cookie) - domain_intermediate <- step5 domain_sanitized - (domain_final, host_only') <- step6 domain_intermediate - http_only' <- step10 - return $ Cookie { cookie_name = setCookieName set_cookie - , cookie_value = setCookieValue set_cookie - , cookie_expiry_time = getExpiryTime (setCookieExpires set_cookie) (setCookieMaxAge set_cookie) - , cookie_domain = domain_final - , cookie_path = getPath $ setCookiePath set_cookie - , cookie_creation_time = now - , cookie_last_access_time = now - , cookie_persistent = getPersistent - , cookie_host_only = host_only' - , cookie_secure_only = setCookieSecure set_cookie - , cookie_http_only = http_only' - } - where sanitizeDomain domain' - | has_a_character && BS.singleton (BS.last domain') == U.fromString "." = Nothing - | has_a_character && BS.singleton (BS.head domain') == U.fromString "." = Just $ BS.tail domain' - | otherwise = Just $ domain' - where has_a_character = not (BS.null domain') - step4 (Just set_cookie_domain) = set_cookie_domain - step4 Nothing = BS.empty - step5 domain' - | firstCondition && domain' == (Req.host request) = return BS.empty - | firstCondition = Nothing - | otherwise = return domain' - where firstCondition = rejectPublicSuffixes && 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) diff --git a/Network/HTTP/Conduit/Internal.hs b/Network/HTTP/Conduit/Internal.hs deleted file mode 100644 --- a/Network/HTTP/Conduit/Internal.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Network.HTTP.Conduit.Internal - ( module Network.HTTP.Conduit.Parser - ) where - -import Network.HTTP.Conduit.Parser diff --git a/Network/HTTP/Conduit/Manager.hs b/Network/HTTP/Conduit/Manager.hs deleted file mode 100644 --- a/Network/HTTP/Conduit/Manager.hs +++ /dev/null @@ -1,437 +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 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 :: S8.ByteString -> [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 :: S8.ByteString -> [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 :: S8.ByteString -> [X509] -> IO TLSCertificateUsage - -- ^ Check if a certificate is valid. - , mCertCache :: !(I.IORef (Map.Map S8.ByteString (Map.Map X509Encoded UTCTime))) - -- ^ Cache of validated certificates. The @UTCTime@ gives the expiration - -- time for the validity of the certificate. The @Ascii@ is the hostname. - } - -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 S8.ByteString (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 -> S8.ByteString -> [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 diff --git a/Network/HTTP/Conduit/Parser.hs b/Network/HTTP/Conduit/Parser.hs deleted file mode 100644 --- a/Network/HTTP/Conduit/Parser.hs +++ /dev/null @@ -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 diff --git a/Network/HTTP/Conduit/Request.hs b/Network/HTTP/Conduit/Request.hs deleted file mode 100644 --- a/Network/HTTP/Conduit/Request.hs +++ /dev/null @@ -1,376 +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 --- . -data Request m = Request - { method :: W.Method - -- ^ HTTP request method, eg GET, POST. - , secure :: Bool - -- ^ Whether to use HTTPS (ie, SSL). - , host :: S.ByteString - , port :: Int - , path :: S.ByteString - -- ^ Everything from the host to the query string. - , queryString :: S.ByteString - , requestHeaders :: W.RequestHeaders - -- ^ Custom HTTP request headers - -- - -- As already stated in the introduction, the Content-Length and Host - -- headers are set automatically by this module, and shall not be added to - -- requestHeaders. - -- - -- Moreover, the Accept-Encoding header is set implicitly to gzip for - -- convenience by default. This behaviour can be overridden if needed, by - -- setting the header explicitly to a different value. In order to omit the - -- Accept-Header altogether, set it to the empty string \"\". If you need an - -- empty Accept-Header (i.e. requesting the identity encoding), set it to a - -- non-empty white-space string, e.g. \" \". See RFC 2616 section 14.3 for - -- details about the semantics of the Accept-Header field. If you request a - -- content-encoding not supported by this module, you will have to decode - -- it yourself (see also the 'decompress' field). - -- - -- Note: Multiple header fields with the same field-name will result in - -- multiple header fields being sent and therefore it\'s the responsibility - -- of the client code to ensure that the rules from RFC 2616 section 4.2 - -- are honoured. - , requestBody :: RequestBody m - , proxy :: Maybe Proxy - -- ^ Optional HTTP proxy. - , socksProxy :: Maybe SocksConf - -- ^ Optional SOCKS proxy. - , 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 :: S.ByteString -- ^ 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") - - acceptEncodingHeader = - case lookup "Accept-Encoding" $ requestHeaders req of - Nothing -> (("Accept-Encoding", "gzip"):) - Just "" -> filter (\(k, _) -> k /= "Accept-Encoding") - Just _ -> id - - hostHeader = (("Host", hh):) - - headerPairs :: W.RequestHeaders - headerPairs = hostHeader - $ acceptEncodingHeader - $ 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" diff --git a/Network/HTTP/Conduit/Response.hs b/Network/HTTP/Conduit/Response.hs deleted file mode 100644 --- a/Network/HTTP/Conduit/Response.hs +++ /dev/null @@ -1,155 +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 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 Data.Conduit hiding (Sink, Conduit) -import Data.Conduit.Internal (ResumableSource (..), Pipe (..)) -import qualified Data.Conduit.Zlib as CZ -import qualified Data.Conduit.Binary as CB -import qualified Data.Conduit.List as CL - -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 (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 (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 'Source' body to one with a lazy --- 'L.ByteString' body. -lbsResponse :: Monad m - => m (Response (ResumableSource m S8.ByteString)) - -> m (Response L.ByteString) -lbsResponse mres = do - res <- mres - bss <- responseBody res $$+- CL.consume - return res - { responseBody = L.fromChunks bss - } - --- | This function can\'t be a Conduit, since it would lose leftovers. -checkHeaderLength :: MonadResource m - => Int - -> Pipe S8.ByteString S8.ByteString Void u m r - -> Pipe S8.ByteString S8.ByteString Void u m r -checkHeaderLength len NeedInput{} - | len <= 0 = liftIO $ throwIO OverlongHeaders -checkHeaderLength len (NeedInput pushI closeI) = NeedInput - (\bs -> checkHeaderLength - (len - S8.length bs) - (pushI bs)) closeI -checkHeaderLength len (PipeM msink) = PipeM (liftM (checkHeaderLength len) msink) -checkHeaderLength _ s@Done{} = s -checkHeaderLength _ (HaveOutput _ _ o) = absurd o -checkHeaderLength len (Leftover p i) = Leftover (checkHeaderLength len p) i - -getResponse :: MonadResource m - => ConnRelease m - -> Request m - -> Source m S8.ByteString - -> m (Response (ResumableSource m S8.ByteString)) -getResponse connRelease req@(Request {..}) src1 = do - (src2, ((vbs, sc, sm), hs)) <- src1 $$+ 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 - (rsrc, ()) <- return () $$+ return () - return rsrc - else do - let src3 = - if ("transfer-encoding", "chunked") `elem` hs' - then fmapResume ($= chunkedConduit rawBody) src2 - else - case mcl of - Just len -> fmapResume ($= CB.isolate len) src2 - Nothing -> src2 - let src4 = - if needsGunzip req hs' - then fmapResume ($= CZ.ungzip) src3 - else src3 - return $ addCleanup' cleanup src4 - - return $ Response s version hs' body - where - fmapResume f (ResumableSource src m) = ResumableSource (f src) m - addCleanup' f (ResumableSource src m) = ResumableSource (addCleanup f src) (m >> f False) diff --git a/Network/HTTP/Conduit/Util.hs b/Network/HTTP/Conduit/Util.hs deleted file mode 100644 --- a/Network/HTTP/Conduit/Util.hs +++ /dev/null @@ -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 diff --git a/Network/HTTP/Simple.hs b/Network/HTTP/Simple.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Simple.hs @@ -0,0 +1,521 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE OverloadedStrings #-} +-- | Simplified interface for common HTTP client interactions. Tutorial +-- available at +-- +-- +-- Important note: 'H.Request' is an instance of 'Data.String.IsString', and +-- therefore recommended usage is to turn on @OverloadedStrings@, e.g. +-- +-- > {-# LANGUAGE OverloadedStrings #-} +-- > import Network.HTTP.Simple +-- > import qualified Data.ByteString.Char8 as B8 +-- > +-- > main :: IO () +-- > main = httpBS "http://example.com" >>= B8.putStrLn . getResponseBody +-- +-- The `Data.String.IsString` instance uses `H.parseRequest` behind the scenes and inherits its behavior. +module Network.HTTP.Simple + ( -- * Perform requests + httpBS + , httpLBS + , httpNoBody +#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 diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 diff --git a/certificate.pem b/certificate.pem new file mode 100644 --- /dev/null +++ b/certificate.pem @@ -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----- diff --git a/http-conduit.cabal b/http-conduit.cabal --- a/http-conduit.cabal +++ b/http-conduit.cabal @@ -1,122 +1,98 @@ +cabal-version: >= 1.10 name: http-conduit -version: 1.5.0.3 +version: 2.3.9.1 license: BSD3 license-file: LICENSE author: Michael Snoyman maintainer: Michael Snoyman 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 for more information. +description: Hackage documentation generation is not reliable. For up to date documentation, please see: . category: Web, Conduit stability: Stable -cabal-version: >= 1.8 build-type: Simple -homepage: http://www.yesodweb.com/book/http-conduit +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.5 && < 0.6 - , zlib-conduit >= 0.5 && < 0.6 - , blaze-builder-conduit >= 0.5 && < 0.6 - , attoparsec-conduit >= 0.5 && < 0.6 - , 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.8 - , 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 - , 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 diff --git a/key.pem b/key.pem new file mode 100644 --- /dev/null +++ b/key.pem @@ -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----- diff --git a/multipart-example.bin b/multipart-example.bin new file mode 100644 Binary files /dev/null and b/multipart-example.bin differ diff --git a/nyan.gif b/nyan.gif new file mode 100644 Binary files /dev/null and b/nyan.gif differ diff --git a/test/CookieTest.hs b/test/CookieTest.hs new file mode 100644 --- /dev/null +++ b/test/CookieTest.hs @@ -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 diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -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