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